From d24e5767fe780653d5601b69d981f33e2a62e47e Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 11 Oct 2021 16:16:41 +0200 Subject: [PATCH] [Ada] Expose and use type-generic GCC atomic builtins gcc/ada/ * sem_ch12.adb (Analyze_Subprogram_Instantiation): Also propagate an interface name on an intrinsic subprogram. Remove obsolete comment. * libgnat/s-atopri.ads (Atomic_Load): New generic intrinsic function (Atomic_Load_8): Rewrite into instantiation. (Atomic_Load_16): Likewise. (Atomic_Load_32): Likewise. (Atomic_Load_64): Likewise. (Sync_Compare_And_Swap): New generic intrinsic function. (Sync_Compare_And_Swap_8): Rewrite into instantiation. (Sync_Compare_And_Swap_16): Likewise. (Sync_Compare_And_Swap_32): Likewise. (Sync_Compare_And_Swap_64): Likewise. (Lock_Free_Read): New generic inline function. (Lock_Free_Read_8): Rewrite into instantiation. (Lock_Free_Read_16): Likewise. (Lock_Free_Read_32): Likewise. (Lock_Free_Read_64): Likewise. (Lock_Free_Try_Write): New generic inline function. (Lock_Free_Try_Write_8): Rewrite into instantiation. (Lock_Free_Try_Write_16): Likewise. (Lock_Free_Try_Write_32): Likewise. (Lock_Free_Try_Write_64): Likewise. * libgnat/s-atopri.adb (Lock_Free_Read): New function body. (Lock_Free_Read_8): Delete. (Lock_Free_Read_16): Likewise. (Lock_Free_Read_32): Likewise. (Lock_Free_Read_64): Likewise. (Lock_Free_Try_Write): New function body. (Lock_Free_Try_Write_8): Delete. (Lock_Free_Try_Write_16): Likewise. (Lock_Free_Try_Write_32): Likewise. (Lock_Free_Try_Write_64): Likewise. * libgnat/s-aoinar.adb (Atomic_Fetch_And_Add): Use type-generic GCC atomic builtin and tidy up implementation. (Atomic_Fetch_And_Subtract): Likewise. * libgnat/s-aomoar.adb (Atomic_Fetch_And_Add): Likewise. (Atomic_Fetch_And_Subtract): Likewise. * libgnat/s-atopex.adb (Atomic_Exchange): Likewise. (Atomic_Compare_And_Exchange): Likewise. --- gcc/ada/libgnat/s-aoinar.adb | 74 ++++------------ gcc/ada/libgnat/s-aomoar.adb | 80 ++++------------- gcc/ada/libgnat/s-atopex.adb | 83 +++--------------- gcc/ada/libgnat/s-atopri.adb | 161 +++++------------------------------ gcc/ada/libgnat/s-atopri.ads | 145 +++++++++++-------------------- gcc/ada/sem_ch12.adb | 10 +-- 6 files changed, 123 insertions(+), 430 deletions(-) diff --git a/gcc/ada/libgnat/s-aoinar.adb b/gcc/ada/libgnat/s-aoinar.adb index 2f430ed4efec..41d0cda2cde7 100644 --- a/gcc/ada/libgnat/s-aoinar.adb +++ b/gcc/ada/libgnat/s-aoinar.adb @@ -72,22 +72,10 @@ package body System.Atomic_Operations.Integer_Arithmetic is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Fetch_Add_1 + function Atomic_Fetch_Add (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 Import (Intrinsic, Atomic_Fetch_Add, "__atomic_fetch_add"); pragma Warnings (On); begin @@ -96,21 +84,14 @@ package body System.Atomic_Operations.Integer_Arithmetic is if Atomic_Type'Base'Last = Atomic_Type'Last and then Atomic_Type'Base'First = Atomic_Type'First - and then Atomic_Type'Last - in 2 ** 7 - 1 | 2 ** 15 - 1 | 2 ** 31 - 1 | 2 ** 63 - 1 + and then Atomic_Type'Last = 2**(Atomic_Type'Object_Size - 1) - 1 then - case Long_Long_Integer (Atomic_Type'Last) is - when 2 ** 7 - 1 => - return Atomic_Fetch_Add_1 (Item'Address, Value); - when 2 ** 15 - 1 => - return Atomic_Fetch_Add_2 (Item'Address, Value); - when 2 ** 31 - 1 => - return Atomic_Fetch_Add_4 (Item'Address, Value); - when 2 ** 63 - 1 => - return Atomic_Fetch_Add_8 (Item'Address, Value); - when others => - raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Fetch_Add (Item'Address, Value); + else + raise Program_Error; + end if; + else declare Old_Value : aliased Atomic_Type := Item; @@ -138,22 +119,10 @@ package body System.Atomic_Operations.Integer_Arithmetic is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Fetch_Sub_1 + function Atomic_Fetch_Sub (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 Import (Intrinsic, Atomic_Fetch_Sub, "__atomic_fetch_sub"); pragma Warnings (On); begin @@ -162,21 +131,14 @@ package body System.Atomic_Operations.Integer_Arithmetic is if Atomic_Type'Base'Last = Atomic_Type'Last and then Atomic_Type'Base'First = Atomic_Type'First - and then Atomic_Type'Last - in 2 ** 7 - 1 | 2 ** 15 - 1 | 2 ** 31 - 1 | 2 ** 63 - 1 + and then Atomic_Type'Last = 2**(Atomic_Type'Object_Size - 1) - 1 then - case Long_Long_Integer (Atomic_Type'Last) is - when 2 ** 7 - 1 => - return Atomic_Fetch_Sub_1 (Item'Address, Value); - when 2 ** 15 - 1 => - return Atomic_Fetch_Sub_2 (Item'Address, Value); - when 2 ** 31 - 1 => - return Atomic_Fetch_Sub_4 (Item'Address, Value); - when 2 ** 63 - 1 => - return Atomic_Fetch_Sub_8 (Item'Address, Value); - when others => - raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Fetch_Sub (Item'Address, Value); + else + raise Program_Error; + end if; + else declare Old_Value : aliased Atomic_Type := Item; diff --git a/gcc/ada/libgnat/s-aomoar.adb b/gcc/ada/libgnat/s-aomoar.adb index a6f4b0e61e80..617a5b30de3a 100644 --- a/gcc/ada/libgnat/s-aomoar.adb +++ b/gcc/ada/libgnat/s-aomoar.adb @@ -72,48 +72,26 @@ package body System.Atomic_Operations.Modular_Arithmetic is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Fetch_Add_1 + function Atomic_Fetch_Add (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 Import (Intrinsic, Atomic_Fetch_Add, "__atomic_fetch_add"); 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 + and then Atomic_Type'Last = 2**Atomic_Type'Object_Size - 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; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Fetch_Add (Item'Address, Value); + else + raise Program_Error; + end if; + else declare Old_Value : aliased Atomic_Type := Item; @@ -141,48 +119,26 @@ package body System.Atomic_Operations.Modular_Arithmetic is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Fetch_Sub_1 + function Atomic_Fetch_Sub (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 Import (Intrinsic, Atomic_Fetch_Sub, "__atomic_fetch_sub"); 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 + and then Atomic_Type'Last = 2**Atomic_Type'Object_Size - 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; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Fetch_Sub (Item'Address, Value); + else + raise Program_Error; + end if; + else declare Old_Value : aliased Atomic_Type := Item; diff --git a/gcc/ada/libgnat/s-atopex.adb b/gcc/ada/libgnat/s-atopex.adb index b0aa9e593d1b..65e943350dd3 100644 --- a/gcc/ada/libgnat/s-atopex.adb +++ b/gcc/ada/libgnat/s-atopex.adb @@ -43,36 +43,19 @@ package body System.Atomic_Operations.Exchange is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Exchange_1 + function Atomic_Exchange (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Exchange_1, "__atomic_exchange_1"); - function Atomic_Exchange_2 - (Ptr : System.Address; - Val : Atomic_Type; - Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Exchange_2, "__atomic_exchange_2"); - function Atomic_Exchange_4 - (Ptr : System.Address; - Val : Atomic_Type; - Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Exchange_4, "__atomic_exchange_4"); - function Atomic_Exchange_8 - (Ptr : System.Address; - Val : Atomic_Type; - Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Exchange_8, "__atomic_exchange_8"); + pragma Import (Intrinsic, Atomic_Exchange, "__atomic_exchange_n"); pragma Warnings (On); begin - case Atomic_Type'Object_Size is - when 8 => return Atomic_Exchange_1 (Item'Address, Value); - when 16 => return Atomic_Exchange_2 (Item'Address, Value); - when 32 => return Atomic_Exchange_4 (Item'Address, Value); - when 64 => return Atomic_Exchange_8 (Item'Address, Value); - when others => raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Exchange (Item'Address, Value); + else + raise Program_Error; + end if; end Atomic_Exchange; --------------------------------- @@ -85,34 +68,7 @@ package body System.Atomic_Operations.Exchange is Desired : Atomic_Type) return Boolean is pragma Warnings (Off); - function Atomic_Compare_Exchange_1 - (Ptr : System.Address; - Expected : System.Address; - Desired : Atomic_Type; - Weak : Boolean := False; - Success_Model : Mem_Model := Seq_Cst; - Failure_Model : Mem_Model := Seq_Cst) return Boolean; - pragma Import - (Intrinsic, Atomic_Compare_Exchange_1, "__atomic_compare_exchange_1"); - function Atomic_Compare_Exchange_2 - (Ptr : System.Address; - Expected : System.Address; - Desired : Atomic_Type; - Weak : Boolean := False; - Success_Model : Mem_Model := Seq_Cst; - Failure_Model : Mem_Model := Seq_Cst) return Boolean; - pragma Import - (Intrinsic, Atomic_Compare_Exchange_2, "__atomic_compare_exchange_2"); - function Atomic_Compare_Exchange_4 - (Ptr : System.Address; - Expected : System.Address; - Desired : Atomic_Type; - Weak : Boolean := False; - Success_Model : Mem_Model := Seq_Cst; - Failure_Model : Mem_Model := Seq_Cst) return Boolean; - pragma Import - (Intrinsic, Atomic_Compare_Exchange_4, "__atomic_compare_exchange_4"); - function Atomic_Compare_Exchange_8 + function Atomic_Compare_Exchange (Ptr : System.Address; Expected : System.Address; Desired : Atomic_Type; @@ -120,26 +76,15 @@ package body System.Atomic_Operations.Exchange is Success_Model : Mem_Model := Seq_Cst; Failure_Model : Mem_Model := Seq_Cst) return Boolean; pragma Import - (Intrinsic, Atomic_Compare_Exchange_8, "__atomic_compare_exchange_8"); + (Intrinsic, Atomic_Compare_Exchange, "__atomic_compare_exchange_n"); pragma Warnings (On); begin - case Atomic_Type'Object_Size is - when 8 => - return - Atomic_Compare_Exchange_1 (Item'Address, Prior'Address, Desired); - when 16 => - return - Atomic_Compare_Exchange_2 (Item'Address, Prior'Address, Desired); - when 32 => - return - Atomic_Compare_Exchange_4 (Item'Address, Prior'Address, Desired); - when 64 => - return - Atomic_Compare_Exchange_8 (Item'Address, Prior'Address, Desired); - when others => - raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Compare_Exchange (Item'Address, Prior'Address, Desired); + else + raise Program_Error; + end if; end Atomic_Compare_And_Exchange; ------------------ diff --git a/gcc/ada/libgnat/s-atopri.adb b/gcc/ada/libgnat/s-atopri.adb index ba284f064213..20aa6666c192 100644 --- a/gcc/ada/libgnat/s-atopri.adb +++ b/gcc/ada/libgnat/s-atopri.adb @@ -31,103 +31,39 @@ package body System.Atomic_Primitives is - ---------------------- - -- Lock_Free_Read_8 -- - ---------------------- + -------------------- + -- Lock_Free_Read -- + -------------------- - function Lock_Free_Read_8 (Ptr : Address) return uint8 is - begin - if uint8'Atomic_Always_Lock_Free then - return Atomic_Load_8 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_8; - - ----------------------- - -- Lock_Free_Read_16 -- - ----------------------- + function Lock_Free_Read (Ptr : Address) return Atomic_Type is + function My_Atomic_Load is new Atomic_Load (Atomic_Type); - function Lock_Free_Read_16 (Ptr : Address) return uint16 is begin - if uint16'Atomic_Always_Lock_Free then - return Atomic_Load_16 (Ptr, Acquire); + if Atomic_Type'Atomic_Always_Lock_Free then + return My_Atomic_Load (Ptr, Acquire); else raise Program_Error; end if; - end Lock_Free_Read_16; + end Lock_Free_Read; - ----------------------- - -- Lock_Free_Read_32 -- - ----------------------- - - function Lock_Free_Read_32 (Ptr : Address) return uint32 is - begin - if uint32'Atomic_Always_Lock_Free then - return Atomic_Load_32 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_32; + ------------------------- + -- Lock_Free_Try_Write -- + ------------------------- - ----------------------- - -- Lock_Free_Read_64 -- - ----------------------- - - function Lock_Free_Read_64 (Ptr : Address) return uint64 is - begin - if uint64'Atomic_Always_Lock_Free then - return Atomic_Load_64 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_64; - - --------------------------- - -- Lock_Free_Try_Write_8 -- - --------------------------- - - function Lock_Free_Try_Write_8 + function Lock_Free_Try_Write (Ptr : Address; - Expected : in out uint8; - Desired : uint8) return Boolean + Expected : in out Atomic_Type; + Desired : Atomic_Type) return Boolean is - Actual : uint8; + function My_Sync_Compare_And_Swap is + new Sync_Compare_And_Swap (Atomic_Type); - begin - if Expected /= Desired then - - if uint8'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_8 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_8; - - ---------------------------- - -- Lock_Free_Try_Write_16 -- - ---------------------------- - - function Lock_Free_Try_Write_16 - (Ptr : Address; - Expected : in out uint16; - Desired : uint16) return Boolean - is - Actual : uint16; + Actual : Atomic_Type; begin if Expected /= Desired then - - if uint16'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_16 (Ptr, Expected, Desired); + if Atomic_Type'Atomic_Always_Lock_Free then + Actual := My_Sync_Compare_And_Swap (Ptr, Expected, Desired); else raise Program_Error; end if; @@ -139,63 +75,6 @@ package body System.Atomic_Primitives is end if; return True; - end Lock_Free_Try_Write_16; - - ---------------------------- - -- Lock_Free_Try_Write_32 -- - ---------------------------- + end Lock_Free_Try_Write; - function Lock_Free_Try_Write_32 - (Ptr : Address; - Expected : in out uint32; - Desired : uint32) return Boolean - is - Actual : uint32; - - begin - if Expected /= Desired then - - if uint32'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_32 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_32; - - ---------------------------- - -- Lock_Free_Try_Write_64 -- - ---------------------------- - - function Lock_Free_Try_Write_64 - (Ptr : Address; - Expected : in out uint64; - Desired : uint64) return Boolean - is - Actual : uint64; - - begin - if Expected /= Desired then - - if uint64'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_64 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_64; end System.Atomic_Primitives; diff --git a/gcc/ada/libgnat/s-atopri.ads b/gcc/ada/libgnat/s-atopri.ads index 891b2edf061e..ea03f1a7d508 100644 --- a/gcc/ada/libgnat/s-atopri.ads +++ b/gcc/ada/libgnat/s-atopri.ads @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- This package contains both atomic primitives defined from gcc built-in +-- This package contains both atomic primitives defined from GCC built-in -- functions and operations used by the compiler to generate the lock-free -- implementation of protected objects. @@ -66,71 +66,31 @@ package System.Atomic_Primitives is -- GCC built-in atomic primitives -- ------------------------------------ - function Atomic_Load_8 + generic + type Atomic_Type is mod <>; + function Atomic_Load (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint8; - pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); + Model : Mem_Model := Seq_Cst) return Atomic_Type; + pragma Import (Intrinsic, Atomic_Load, "__atomic_load_n"); - function Atomic_Load_16 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint16; - pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); - - function Atomic_Load_32 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint32; - pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); - - function Atomic_Load_64 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint64; - pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); - - function Sync_Compare_And_Swap_8 - (Ptr : Address; - Expected : uint8; - Desired : uint8) return uint8; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_8, - "__sync_val_compare_and_swap_1"); - - function Sync_Compare_And_Swap_16 - (Ptr : Address; - Expected : uint16; - Desired : uint16) return uint16; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_16, - "__sync_val_compare_and_swap_2"); + function Atomic_Load_8 is new Atomic_Load (uint8); + function Atomic_Load_16 is new Atomic_Load (uint16); + function Atomic_Load_32 is new Atomic_Load (uint32); + function Atomic_Load_64 is new Atomic_Load (uint64); - function Sync_Compare_And_Swap_32 + generic + type Atomic_Type is mod <>; + function Sync_Compare_And_Swap (Ptr : Address; - Expected : uint32; - Desired : uint32) return uint32; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_32, - "__sync_val_compare_and_swap_4"); + Expected : Atomic_Type; + Desired : Atomic_Type) return Atomic_Type; + pragma Import + (Intrinsic, Sync_Compare_And_Swap, "__sync_val_compare_and_swap"); - function Sync_Compare_And_Swap_64 - (Ptr : Address; - Expected : uint64; - Desired : uint64) return uint64; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_64, - "__sync_val_compare_and_swap_8"); - - -- ??? We might want to switch to the __atomic series of builtins for - -- compare-and-swap operations at some point. - - -- function Atomic_Compare_Exchange_8 - -- (Ptr : Address; - -- Expected : Address; - -- Desired : uint8; - -- Weak : Boolean := False; - -- Success_Model : Mem_Model := Seq_Cst; - -- Failure_Model : Mem_Model := Seq_Cst) return Boolean; - -- pragma Import (Intrinsic, - -- Atomic_Compare_Exchange_8, - -- "__atomic_compare_exchange_1"); + function Sync_Compare_And_Swap_8 is new Sync_Compare_And_Swap (uint8); + function Sync_Compare_And_Swap_16 is new Sync_Compare_And_Swap (uint16); + function Sync_Compare_And_Swap_32 is new Sync_Compare_And_Swap (uint32); + function Sync_Compare_And_Swap_64 is new Sync_Compare_And_Swap (uint64); function Atomic_Test_And_Set (Ptr : System.Address; @@ -155,46 +115,37 @@ package System.Atomic_Primitives is -- The lock-free implementation uses two atomic instructions for the -- expansion of protected operations: - -- * Lock_Free_Read_N atomically loads the value of the protected component - -- accessed by the current protected operation. - - -- * Lock_Free_Try_Write_N tries to write the Desired value into Ptr only - -- if Expected and Desired mismatch. + -- * Lock_Free_Read atomically loads the value contained in Ptr (with the + -- Acquire synchronization mode). - function Lock_Free_Read_8 (Ptr : Address) return uint8; + -- * Lock_Free_Try_Write atomically tries to write the Desired value into + -- Ptr if Ptr contains the Expected value. It returns true if the value + -- in Ptr was changed, or False if it was not, in which case Expected is + -- updated to the unexpected value in Ptr. Note that it does nothing and + -- returns true if Desired and Expected are equal. - function Lock_Free_Read_16 (Ptr : Address) return uint16; + generic + type Atomic_Type is mod <>; + function Lock_Free_Read (Ptr : Address) return Atomic_Type; - function Lock_Free_Read_32 (Ptr : Address) return uint32; + function Lock_Free_Read_8 is new Lock_Free_Read (uint8); + function Lock_Free_Read_16 is new Lock_Free_Read (uint16); + function Lock_Free_Read_32 is new Lock_Free_Read (uint32); + function Lock_Free_Read_64 is new Lock_Free_Read (uint64); - function Lock_Free_Read_64 (Ptr : Address) return uint64; - - function Lock_Free_Try_Write_8 - (Ptr : Address; - Expected : in out uint8; - Desired : uint8) return Boolean; - - function Lock_Free_Try_Write_16 - (Ptr : Address; - Expected : in out uint16; - Desired : uint16) return Boolean; - - function Lock_Free_Try_Write_32 - (Ptr : Address; - Expected : in out uint32; - Desired : uint32) return Boolean; + generic + type Atomic_Type is mod <>; + function Lock_Free_Try_Write + (Ptr : Address; + Expected : in out Atomic_Type; + Desired : Atomic_Type) return Boolean; - function Lock_Free_Try_Write_64 - (Ptr : Address; - Expected : in out uint64; - Desired : uint64) return Boolean; + function Lock_Free_Try_Write_8 is new Lock_Free_Try_Write (uint8); + function Lock_Free_Try_Write_16 is new Lock_Free_Try_Write (uint16); + function Lock_Free_Try_Write_32 is new Lock_Free_Try_Write (uint32); + function Lock_Free_Try_Write_64 is new Lock_Free_Try_Write (uint64); - pragma Inline (Lock_Free_Read_8); - pragma Inline (Lock_Free_Read_16); - pragma Inline (Lock_Free_Read_32); - pragma Inline (Lock_Free_Read_64); - pragma Inline (Lock_Free_Try_Write_8); - pragma Inline (Lock_Free_Try_Write_16); - pragma Inline (Lock_Free_Try_Write_32); - pragma Inline (Lock_Free_Try_Write_64); +private + pragma Inline (Lock_Free_Read); + pragma Inline (Lock_Free_Try_Write); end System.Atomic_Primitives; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e4cb7e3229c3..54406e9bbc53 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5802,6 +5802,7 @@ package body Sem_Ch12 is if Is_Intrinsic_Subprogram (Gen_Unit) then Set_Is_Intrinsic_Subprogram (Anon_Id); + Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit)); end if; Analyze_Instance_And_Renamings; @@ -5818,14 +5819,13 @@ package body Sem_Ch12 is end if; -- If the generic is marked Import (Intrinsic), then so is the - -- instance. This indicates that there is no body to instantiate. If - -- generic is marked inline, so it the instance, and the anonymous - -- subprogram it renames. If inlined, or else if inlining is enabled - -- for the compilation, we generate the instance body even if it is - -- not within the main unit. + -- instance; this indicates that there is no body to instantiate. + -- We also copy the interface name in case this is handled by the + -- back-end and deal with an instance of unchecked conversion. if Is_Intrinsic_Subprogram (Gen_Unit) then Set_Is_Intrinsic_Subprogram (Act_Decl_Id); + Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit)); if Chars (Gen_Unit) = Name_Unchecked_Conversion then Validate_Unchecked_Conversion (N, Act_Decl_Id); -- 2.47.2