From da2e82e93b2eea1ceb9313addf4168df97736c6c Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 12 Jul 2012 10:43:18 +0000 Subject: [PATCH] 2012-07-12 Robert Dewar * sem_disp.adb: Minor reformatting * s-bytswa.ads: Minor comment update. 2012-07-12 Vincent Pucci * exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body): Atomic_Load_N replaced by Lock_Free_Read_N. Atomic_Compare_Exchange_N replaced by Lock_Free_Try_Write_N. Renaming of several local variables. For procedure, Expected_Comp declaration moved to the declaration list of the procedure. * rtsfind.ads: RE_Atomic_Compare_Exchange_8, RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32, RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8, RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, RE_Atomic_Synchronize, RE_Relaxed removed. RE_Lock_Free_Read_8, RE_Lock_Free_Read_16, RE_Lock_Free_Read_32, RE_Lock_Free_Read_64, RE_Lock_Free_Try_Write_8, RE_Lock_Free_Try_Write_16, RE_Lock_Free_Try_Write_32, RE_Lock_Free_Try_Write_64 added. * s-atopri.adb: New file. * s-atopri.ads (Atomic_Compare_Exchange_8): Renaming of parameters. Import primitive __sync_val_compare_and_swap_1. (Atomic_Compare_Exchange_16): Renaming of parameters. Import primitive __sync_val_compare_and_swap_2. (Atomic_Compare_Exchange_32): Renaming of parameters. Import primitive __sync_val_compare_and_swap_4. (Atomic_Compare_Exchange_64): Renaming of parameters. Import primitive __sync_val_compare_and_swap_8. (Atomic_Load_8): Ptr renames parameter X. (Atomic_Load_16): Ptr renames parameter X. (Atomic_Load_32): Ptr renames parameter X. (Atomic_Load_64): Ptr renames parameter X. (Lock_Free_Read_8): New routine. (Lock_Free_Read_16): New routine. (Lock_Free_Read_32): New routine. (Lock_Free_Read_64): New routine. (Lock_Free_Try_Write_8): New routine. (Lock_Free_Try_Write_16): New routine. (Lock_Free_Try_Write_32): New routine. (Lock_Free_Try_Write_64): New routine. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@189437 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 43 +++++++++++ gcc/ada/exp_ch9.adb | 208 +++++++++++++++++++++++++-------------------------- gcc/ada/rtsfind.ads | 36 ++++----- gcc/ada/s-atopri.adb | 128 +++++++++++++++++++++++++++++++ gcc/ada/s-atopri.ads | 113 +++++++++++++++++++++------- gcc/ada/s-bytswa.ads | 5 +- gcc/ada/sem_disp.adb | 97 ++++++++++++------------ 7 files changed, 424 insertions(+), 206 deletions(-) create mode 100644 gcc/ada/s-atopri.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 394b1c1..e83f1a7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,48 @@ 2012-07-12 Robert Dewar + * sem_disp.adb: Minor reformatting + * s-bytswa.ads: Minor comment update. + +2012-07-12 Vincent Pucci + + * exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body): + Atomic_Load_N replaced by Lock_Free_Read_N. Atomic_Compare_Exchange_N + replaced by Lock_Free_Try_Write_N. + Renaming of several local variables. For + procedure, Expected_Comp declaration moved to the declaration + list of the procedure. + * rtsfind.ads: RE_Atomic_Compare_Exchange_8, + RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32, + RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8, + RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, + RE_Atomic_Synchronize, RE_Relaxed removed. RE_Lock_Free_Read_8, + RE_Lock_Free_Read_16, RE_Lock_Free_Read_32, RE_Lock_Free_Read_64, + RE_Lock_Free_Try_Write_8, RE_Lock_Free_Try_Write_16, + RE_Lock_Free_Try_Write_32, RE_Lock_Free_Try_Write_64 added. + * s-atopri.adb: New file. + * s-atopri.ads (Atomic_Compare_Exchange_8): Renaming of + parameters. Import primitive __sync_val_compare_and_swap_1. + (Atomic_Compare_Exchange_16): Renaming of parameters. + Import primitive __sync_val_compare_and_swap_2. + (Atomic_Compare_Exchange_32): Renaming of parameters. + Import primitive __sync_val_compare_and_swap_4. + (Atomic_Compare_Exchange_64): Renaming of parameters. Import + primitive __sync_val_compare_and_swap_8. + (Atomic_Load_8): Ptr renames parameter X. + (Atomic_Load_16): Ptr renames parameter X. + (Atomic_Load_32): Ptr renames parameter X. + (Atomic_Load_64): Ptr renames parameter X. + (Lock_Free_Read_8): New routine. + (Lock_Free_Read_16): New routine. + (Lock_Free_Read_32): New routine. + (Lock_Free_Read_64): New routine. + (Lock_Free_Try_Write_8): New routine. + (Lock_Free_Try_Write_16): New routine. + (Lock_Free_Try_Write_32): New routine. + (Lock_Free_Try_Write_64): New routine. + +2012-07-12 Robert Dewar + * exp_attr.adb, exp_ch9.adb, sem_ch9.adb, exp_aggr.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index bd47611..2ce8aed 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -2955,30 +2955,40 @@ package body Exp_Ch9 is -- manner: -- procedure P (...) is + -- Expected_Comp : constant Comp_Type := + -- Comp_Type + -- (System.Atomic_Primitives.Lock_Free_Read_N + -- (_Object.Comp'Address)); -- begin -- loop -- declare -- - -- Saved_Comp : constant ... := - -- Atomic_Load (_Object.Comp'Address, Relaxed); - -- Current_Comp : ... := Saved_Comp; - -- Comp : Comp_Type renames Current_Comp; + -- + -- Desired_Comp : Comp_Type := Expected_Comp; + -- Comp : Comp_Type renames Desired_Comp; + -- -- + -- -- begin -- - -- exit when Atomic_Compare - -- (_Object.Comp, Saved_Comp, Current_Comp); + -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)); -- end; - -- <> -- end loop; -- end P; -- Each return and raise statement of P is transformed into an atomic -- status check: - -- if Atomic_Compare (_Object.Comp, Saved_Comp, Current_Comp) then + -- if System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)); + -- then -- -- else -- goto L0; @@ -2991,10 +3001,16 @@ package body Exp_Ch9 is -- function F (...) return ... is -- - -- Saved_Comp : constant ... := Atomic_Load (_Object.Comp'Address); - -- Comp : Comp_Type renames Saved_Comp; + -- + -- Expected_Comp : constant Comp_Type := + -- Comp_Type + -- (System.Atomic_Primitives.Lock_Free_Read_N + -- (_Object.Comp'Address)); + -- Comp : Comp_Type renames Expected_Comp; + -- -- + -- -- begin -- -- end F; @@ -3003,11 +3019,6 @@ package body Exp_Ch9 is (N : Node_Id; Prot_Typ : Node_Id) return Node_Id is - Is_Procedure : constant Boolean := - Ekind (Corresponding_Spec (N)) = E_Procedure; - Loc : constant Source_Ptr := Sloc (N); - Label_Id : Entity_Id := Empty; - function Referenced_Component (N : Node_Id) return Entity_Id; -- Subprograms which meet the lock-free implementation criteria are -- allowed to reference only one unique component. Return the prival @@ -3068,9 +3079,10 @@ package body Exp_Ch9 is -- Local variables - Comp : constant Entity_Id := Referenced_Component (N); - Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); - Decls : List_Id := Declarations (N); + Comp : constant Entity_Id := Referenced_Component (N); + Loc : constant Source_Ptr := Sloc (N); + Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); + Decls : List_Id := Declarations (N); -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body @@ -3088,19 +3100,24 @@ package body Exp_Ch9 is Comp_Decl : constant Node_Id := Parent (Comp); Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); Comp_Type : constant Entity_Id := Etype (Comp); - Block_Decls : List_Id; - Compare : Entity_Id; - Current_Comp : Entity_Id; - Decl : Node_Id; - Label : Node_Id; - Load : Entity_Id; - Load_Params : List_Id; - Saved_Comp : Entity_Id; - Stmt : Node_Id; - Stmts : List_Id := - New_Copy_List (Statements (Hand_Stmt_Seq)); - Typ_Size : Int; - Unsigned : Entity_Id; + + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (N)) = E_Procedure; + -- Indicates if N is a protected procedure body + + Block_Decls : List_Id; + Try_Write : Entity_Id; + Desired_Comp : Entity_Id; + Decl : Node_Id; + Label : Node_Id; + Label_Id : Entity_Id := Empty; + Read : Entity_Id; + Expected_Comp : Entity_Id; + Stmt : Node_Id; + Stmts : List_Id := + New_Copy_List (Statements (Hand_Stmt_Seq)); + Typ_Size : Int; + Unsigned : Entity_Id; function Process_Node (N : Node_Id) return Traverse_Result; -- Transform a single node if it is a return statement, a raise @@ -3110,10 +3127,10 @@ package body Exp_Ch9 is -- Given a statement sequence Stmts, wrap any return or raise -- statements in the following manner: -- - -- if System.Atomic_Primitives.Atomic_Compare_Exchange - -- (Comp'Address, - -- Interfaces.Unsigned (Saved_Comp), - -- Interfaces.Unsigned (Current_Comp)) + -- if System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)) -- then -- ; -- else @@ -3149,10 +3166,10 @@ package body Exp_Ch9 is -- Generate: - -- if System.Atomic_Primitives.Atomic_Compare_Exchange - -- (Comp'Address, - -- Interfaces.Unsigned (Saved_Comp), - -- Interfaces.Unsigned (Current_Comp)) + -- if System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)) -- then -- ; -- else @@ -3164,17 +3181,17 @@ package body Exp_Ch9 is Condition => Make_Function_Call (Loc, Name => - New_Reference_To (Compare, Loc), + New_Reference_To (Try_Write, Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Relocate_Node (Comp_Sel_Nam), Attribute_Name => Name_Address), Unchecked_Convert_To (Unsigned, - New_Reference_To (Saved_Comp, Loc)), + New_Reference_To (Expected_Comp, Loc)), Unchecked_Convert_To (Unsigned, - New_Reference_To (Current_Comp, Loc)))), + New_Reference_To (Desired_Comp, Loc)))), Then_Statements => New_List (Relocate_Node (Stmt)), @@ -3253,67 +3270,53 @@ package body Exp_Ch9 is case Typ_Size is when 8 => - Compare := RTE (RE_Atomic_Compare_Exchange_8); - Load := RTE (RE_Atomic_Load_8); - Unsigned := RTE (RE_Uint8); + Try_Write := RTE (RE_Lock_Free_Try_Write_8); + Read := RTE (RE_Lock_Free_Read_8); + Unsigned := RTE (RE_Uint8); when 16 => - Compare := RTE (RE_Atomic_Compare_Exchange_16); - Load := RTE (RE_Atomic_Load_16); - Unsigned := RTE (RE_Uint16); + Try_Write := RTE (RE_Lock_Free_Try_Write_16); + Read := RTE (RE_Lock_Free_Read_16); + Unsigned := RTE (RE_Uint16); when 32 => - Compare := RTE (RE_Atomic_Compare_Exchange_32); - Load := RTE (RE_Atomic_Load_32); - Unsigned := RTE (RE_Uint32); + Try_Write := RTE (RE_Lock_Free_Try_Write_32); + Read := RTE (RE_Lock_Free_Read_32); + Unsigned := RTE (RE_Uint32); when 64 => - Compare := RTE (RE_Atomic_Compare_Exchange_64); - Load := RTE (RE_Atomic_Load_64); - Unsigned := RTE (RE_Uint64); + Try_Write := RTE (RE_Lock_Free_Try_Write_64); + Read := RTE (RE_Lock_Free_Read_64); + Unsigned := RTE (RE_Uint64); when others => raise Program_Error; end case; -- Generate: - -- For functions: - - -- Saved_Comp : constant Comp_Type := - -- Comp_Type (Atomic_Load (Comp'Address)); - -- For procedures: + -- Expected_Comp : constant Comp_Type := + -- Comp_Type + -- (System.Atomic_Primitives.Lock_Free_Read_N + -- (_Object.Comp'Address)); - -- Saved_Comp : constant Comp_Type := - -- Comp_Type (Atomic_Load (Comp'Address), - -- Relaxed); - - Saved_Comp := + Expected_Comp := Make_Defining_Identifier (Loc, New_External_Name (Chars (Comp), Suffix => "_saved")); - Load_Params := New_List ( - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Comp_Sel_Nam), - Attribute_Name => Name_Address)); - - -- For protected procedures, set the memory model to be relaxed - - if Is_Procedure then - Append_To (Load_Params, - New_Reference_To (RTE (RE_Relaxed), Loc)); - end if; - Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Saved_Comp, - Constant_Present => True, + Defining_Identifier => Expected_Comp, Object_Definition => New_Reference_To (Comp_Type, Loc), + Constant_Present => True, Expression => Unchecked_Convert_To (Comp_Type, Make_Function_Call (Loc, - Name => New_Reference_To (Load, Loc), - Parameter_Associations => Load_Params))); + Name => New_Reference_To (Read, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Comp_Sel_Nam), + Attribute_Name => Name_Address))))); -- Protected procedures @@ -3322,37 +3325,35 @@ package body Exp_Ch9 is Block_Decls := Decls; - -- Reset the declarations list of the protected procedure to be - -- an empty list. + -- Reset the declarations list of the protected procedure to + -- contain only Decl. - Decls := Empty_List; + Decls := New_List (Decl); -- Generate: - -- Current_Comp : Comp_Type := Saved_Comp; + -- Desired_Comp : Comp_Type := Expected_Comp; - Current_Comp := + Desired_Comp := Make_Defining_Identifier (Loc, New_External_Name (Chars (Comp), Suffix => "_current")); - -- Insert the declarations of Saved_Comp and Current_Comp in + -- Insert the declarations of Expected_Comp and Desired_Comp in -- the block declarations right before the renaming of the -- protected component. - Insert_Before (Comp_Decl, Decl); - Insert_Before (Comp_Decl, Make_Object_Declaration (Loc, - Defining_Identifier => Current_Comp, + Defining_Identifier => Desired_Comp, Object_Definition => New_Reference_To (Comp_Type, Loc), Expression => - New_Reference_To (Saved_Comp, Loc))); + New_Reference_To (Expected_Comp, Loc))); -- Protected function else - Current_Comp := Saved_Comp; + Desired_Comp := Expected_Comp; - -- Insert the declaration of Saved_Comp in the function + -- Insert the declaration of Expected_Comp in the function -- declarations right before the renaming of the protected -- component. @@ -3360,10 +3361,10 @@ package body Exp_Ch9 is end if; -- Rewrite the protected component renaming declaration to be a - -- renaming of Current_Comp. + -- renaming of Desired_Comp. -- Generate: - -- Comp : Comp_Type renames Current_Comp; + -- Comp : Comp_Type renames Desired_Comp; Rewrite (Comp_Decl, Make_Object_Renaming_Declaration (Loc, @@ -3372,7 +3373,7 @@ package body Exp_Ch9 is Subtype_Mark => New_Occurrence_Of (Comp_Type, Loc), Name => - New_Reference_To (Current_Comp, Loc))); + New_Reference_To (Desired_Comp, Loc))); -- Wrap any return or raise statements in Stmts in same the manner -- described in Process_Stmts. @@ -3381,10 +3382,10 @@ package body Exp_Ch9 is -- Generate: - -- exit when System.Atomic_Primitives.Atomic_Compare_Exchange - -- (Comp'Address, - -- Interfaces.Unsigned (Saved_Comp), - -- Interfaces.Unsigned (Current_Comp)) + -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)) if Is_Procedure then Stmt := @@ -3392,17 +3393,17 @@ package body Exp_Ch9 is Condition => Make_Function_Call (Loc, Name => - New_Reference_To (Compare, Loc), + New_Reference_To (Try_Write, Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Relocate_Node (Comp_Sel_Nam), Attribute_Name => Name_Address), Unchecked_Convert_To (Unsigned, - New_Reference_To (Saved_Comp, Loc)), + New_Reference_To (Expected_Comp, Loc)), Unchecked_Convert_To (Unsigned, - New_Reference_To (Current_Comp, Loc))))); + New_Reference_To (Desired_Comp, Loc))))); -- Small optimization: transform the default return statement -- of a procedure into the atomic exit statement. @@ -3439,9 +3440,6 @@ package body Exp_Ch9 is if Is_Procedure then Stmts := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Atomic_Synchronize), Loc)), Make_Loop_Statement (Loc, Statements => New_List ( Make_Block_Statement (Loc, diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 5b7345f..2a16fdf 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -731,16 +731,14 @@ package Rtsfind is RE_Assert_Failure, -- System.Assertions RE_Raise_Assert_Failure, -- System.Assertions - RE_Atomic_Compare_Exchange_8, -- System.Atomic_Primitives - RE_Atomic_Compare_Exchange_16, -- System.Atomic_Primitives - RE_Atomic_Compare_Exchange_32, -- System.Atomic_Primitives - RE_Atomic_Compare_Exchange_64, -- System.Atomic_Primitives - RE_Atomic_Load_8, -- System.Atomic_Primitives - RE_Atomic_Load_16, -- System.Atomic_Primitives - RE_Atomic_Load_32, -- System.Atomic_Primitives - RE_Atomic_Load_64, -- System.Atomic_Primitives - RE_Atomic_Synchronize, -- System.Atomic_Primitives - RE_Relaxed, -- System.Atomic_Primitives + RE_Lock_Free_Read_8, -- System.Atomic_Primitives + RE_Lock_Free_Read_16, -- System.Atomic_Primitives + RE_Lock_Free_Read_32, -- System.Atomic_Primitives + RE_Lock_Free_Read_64, -- System.Atomic_Primitives + RE_Lock_Free_Try_Write_8, -- System.Atomic_Primitives + RE_Lock_Free_Try_Write_16, -- System.Atomic_Primitives + RE_Lock_Free_Try_Write_32, -- System.Atomic_Primitives + RE_Lock_Free_Try_Write_64, -- System.Atomic_Primitives RE_Uint8, -- System.Atomic_Primitives RE_Uint16, -- System.Atomic_Primitives RE_Uint32, -- System.Atomic_Primitives @@ -1955,16 +1953,14 @@ package Rtsfind is RE_Assert_Failure => System_Assertions, RE_Raise_Assert_Failure => System_Assertions, - RE_Atomic_Compare_Exchange_8 => System_Atomic_Primitives, - RE_Atomic_Compare_Exchange_16 => System_Atomic_Primitives, - RE_Atomic_Compare_Exchange_32 => System_Atomic_Primitives, - RE_Atomic_Compare_Exchange_64 => System_Atomic_Primitives, - RE_Atomic_Load_8 => System_Atomic_Primitives, - RE_Atomic_Load_16 => System_Atomic_Primitives, - RE_Atomic_Load_32 => System_Atomic_Primitives, - RE_Atomic_Load_64 => System_Atomic_Primitives, - RE_Atomic_Synchronize => System_Atomic_Primitives, - RE_Relaxed => System_Atomic_Primitives, + RE_Lock_Free_Read_8 => System_Atomic_Primitives, + RE_Lock_Free_Read_16 => System_Atomic_Primitives, + RE_Lock_Free_Read_32 => System_Atomic_Primitives, + RE_Lock_Free_Read_64 => System_Atomic_Primitives, + RE_Lock_Free_Try_Write_8 => System_Atomic_Primitives, + RE_Lock_Free_Try_Write_16 => System_Atomic_Primitives, + RE_Lock_Free_Try_Write_32 => System_Atomic_Primitives, + RE_Lock_Free_Try_Write_64 => System_Atomic_Primitives, RE_Uint8 => System_Atomic_Primitives, RE_Uint16 => System_Atomic_Primitives, RE_Uint32 => System_Atomic_Primitives, diff --git a/gcc/ada/s-atopri.adb b/gcc/ada/s-atopri.adb new file mode 100644 index 0000000..af52128 --- /dev/null +++ b/gcc/ada/s-atopri.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012, 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. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Atomic_Primitives is + --------------------------- + -- Lock_Free_Try_Write_8 -- + --------------------------- + + function Lock_Free_Try_Write_8 + (Ptr : Address; + Expected : in out uint8; + Desired : uint8) return Boolean + is + Actual : uint8; + + begin + if Expected /= Desired then + Actual := Atomic_Compare_Exchange_8 (Ptr, Expected, Desired); + + 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; + + begin + if Expected /= Desired then + Actual := Atomic_Compare_Exchange_16 (Ptr, Expected, Desired); + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_16; + + ---------------------------- + -- Lock_Free_Try_Write_32 -- + ---------------------------- + + function Lock_Free_Try_Write_32 + (Ptr : Address; + Expected : in out uint32; + Desired : uint32) return Boolean + is + Actual : uint32; + + begin + if Expected /= Desired then + Actual := Atomic_Compare_Exchange_32 (Ptr, Expected, Desired); + + 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 + Actual := Atomic_Compare_Exchange_64 (Ptr, Expected, Desired); + + 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/s-atopri.ads b/gcc/ada/s-atopri.ads index 3b87eb2..c0a9703 100644 --- a/gcc/ada/s-atopri.ads +++ b/gcc/ada/s-atopri.ads @@ -29,10 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains atomic primitives defined from gcc built-in functions - --- For now, these operations are only used by the compiler to generate the --- lock-free implementation of protected objects. +-- 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. package System.Atomic_Primitives is pragma Preelaborate; @@ -59,19 +58,24 @@ package System.Atomic_Primitives is subtype Mem_Model is Integer range Relaxed .. Last; + ------------------------------------ + -- GCC built-in atomic primitives -- + ------------------------------------ + function Atomic_Compare_Exchange_8 - (X : Address; - X_Old : uint8; - X_Copy : uint8) return Boolean; + (Ptr : Address; + Expected : uint8; + Desired : uint8) return uint8; pragma Import (Intrinsic, Atomic_Compare_Exchange_8, - "__sync_bool_compare_and_swap_1"); + "__sync_val_compare_and_swap_1"); -- ??? Should use __atomic_compare_exchange_1 (doesn't work yet): -- function Atomic_Compare_Exchange_8 - -- (X : Address; - -- X_Old : Address; - -- X_Copy : uint8; + -- (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, @@ -79,49 +83,100 @@ package System.Atomic_Primitives is -- "__atomic_compare_exchange_1"); function Atomic_Compare_Exchange_16 - (X : Address; - X_Old : uint16; - X_Copy : uint16) return Boolean; + (Ptr : Address; + Expected : uint16; + Desired : uint16) return uint16; pragma Import (Intrinsic, Atomic_Compare_Exchange_16, - "__sync_bool_compare_and_swap_2"); + "__sync_val_compare_and_swap_2"); function Atomic_Compare_Exchange_32 - (X : Address; - X_Old : uint32; - X_Copy : uint32) return Boolean; + (Ptr : Address; + Expected : uint32; + Desired : uint32) return uint32; pragma Import (Intrinsic, Atomic_Compare_Exchange_32, - "__sync_bool_compare_and_swap_4"); + "__sync_val_compare_and_swap_4"); function Atomic_Compare_Exchange_64 - (X : Address; - X_Old : uint64; - X_Copy : uint64) return Boolean; + (Ptr : Address; + Expected : uint64; + Desired : uint64) return uint64; pragma Import (Intrinsic, Atomic_Compare_Exchange_64, - "__sync_bool_compare_and_swap_8"); + "__sync_val_compare_and_swap_8"); function Atomic_Load_8 - (X : Address; + (Ptr : Address; Model : Mem_Model := Seq_Cst) return uint8; pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); function Atomic_Load_16 - (X : Address; + (Ptr : Address; Model : Mem_Model := Seq_Cst) return uint16; pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); function Atomic_Load_32 - (X : Address; + (Ptr : Address; Model : Mem_Model := Seq_Cst) return uint32; pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); function Atomic_Load_64 - (X : Address; + (Ptr : Address; Model : Mem_Model := Seq_Cst) return uint64; pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); - procedure Atomic_Synchronize; - pragma Import (Intrinsic, Atomic_Synchronize, "__sync_synchronize"); + -------------------------- + -- Lock-free operations -- + -------------------------- + + -- 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 the Desired value into Ptr + -- only if Expected and Desired mismatch. + + function Lock_Free_Read_8 (Ptr : Address) return uint8 is + (Atomic_Load_8 (Ptr, Acquire)); + + function Lock_Free_Read_16 (Ptr : Address) return uint16 is + (Atomic_Load_16 (Ptr, Acquire)); + + function Lock_Free_Read_32 (Ptr : Address) return uint32 is + (Atomic_Load_32 (Ptr, Acquire)); + + function Lock_Free_Read_64 (Ptr : Address) return uint64 is + (Atomic_Load_64 (Ptr, Acquire)); + + 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; + + function Lock_Free_Try_Write_64 + (Ptr : Address; + Expected : in out uint64; + Desired : uint64) return Boolean; + + 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); end System.Atomic_Primitives; diff --git a/gcc/ada/s-bytswa.ads b/gcc/ada/s-bytswa.ads index c011e1e..675e7d8 100644 --- a/gcc/ada/s-bytswa.ads +++ b/gcc/ada/s-bytswa.ads @@ -29,8 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- Supporting routines for GNAT.Byte_Swapping, also used directly by --- expended code. +-- Intrinsic routines for byte swapping. These are used by the expanded code +-- (supporting alternative byte ordering), and by the GNAT.Byte_Swapping run +-- time package which provides user level routines for byte swapping. package System.Byte_Swapping is diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index b728c93..988a78f 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -497,12 +497,11 @@ package body Sem_Disp is Par : Node_Id; procedure Abstract_Context_Error; - -- Indicate that the abstract call that dispatches on result is not - -- dispatching. + -- Error for abstract call dispatching on result is not dispatching - ----------------------------- - -- Bastract_Context_Error -- - ----------------------------- + ---------------------------- + -- Abstract_Context_Error -- + ---------------------------- procedure Abstract_Context_Error is begin @@ -510,9 +509,8 @@ package body Sem_Disp is Error_Msg_N ("call to abstract function must be dispatching", N); - -- This error can occur for a procedure in the case of a - -- call to an abstract formal procedure with a statically - -- tagged operand. + -- This error can occur for a procedure in the case of a call to + -- an abstract formal procedure with a statically tagged operand. else Error_Msg_N @@ -521,6 +519,8 @@ package body Sem_Disp is end if; end Abstract_Context_Error; + -- Start of processing for Check_Dispatching_Context + begin if Is_Abstract_Subprogram (Subp) and then No (Controlling_Argument (N)) @@ -552,14 +552,14 @@ package body Sem_Disp is end if; Par := Parent (N); + if Nkind (Par) = N_Parameter_Association then Par := Parent (Par); end if; while Present (Par) loop - if Nkind_In (Par, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind_In (Par, N_Function_Call, + N_Procedure_Call_Statement) and then Is_Entity_Name (Name (Par)) then declare @@ -571,12 +571,9 @@ package body Sem_Disp is F := First_Formal (Entity (Name (Par))); A := First_Actual (Par); - while Present (F) loop - if Is_Controlling_Formal (F) - and then - (N = A or else Parent (N) = A) + and then (N = A or else Parent (N) = A) then return; end if; @@ -590,8 +587,8 @@ package body Sem_Disp is return; end; - -- For equalitiy operators, one of the operands must - -- be statically or dynamically tagged. + -- For equalitiy operators, one of the operands must be + -- statically or dynamically tagged. elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then if N = Right_Opnd (Par) @@ -667,17 +664,17 @@ package body Sem_Disp is -- If the call doesn't have a controlling actual but does have an -- indeterminate actual that requires dispatching treatment, then an - -- object is needed that will serve as the controlling argument for a - -- dispatching call on the indeterminate actual. This can only occur - -- in the unusual situation of a default actual given by a - -- tag-indeterminate call and where the type of the call is an + -- object is needed that will serve as the controlling argument for + -- a dispatching call on the indeterminate actual. This can only + -- occur in the unusual situation of a default actual given by + -- a tag-indeterminate call and where the type of the call is an -- ancestor of the type associated with a containing call to an -- inherited operation (see AI-239). - -- Rather than create an object of the tagged type, which would be - -- problematic for various reasons (default initialization, - -- discriminants), the tag of the containing call's associated tagged - -- type is directly used to control the dispatching. + -- Rather than create an object of the tagged type, which would + -- be problematic for various reasons (default initialization, + -- discriminants), the tag of the containing call's associated + -- tagged type is directly used to control the dispatching. if No (Control) and then Indeterm_Ancestor_Call @@ -716,8 +713,8 @@ package body Sem_Disp is -- The tag is inherited from the enclosing call (the node -- we are currently analyzing). Explicitly expand the -- actual, since the previous call to Expand (from - -- Resolve_Call) had no way of knowing about the required - -- dispatching. + -- Resolve_Call) had no way of knowing about the + -- required dispatching. Propagate_Tag (Control, Actual); @@ -1034,16 +1031,16 @@ package body Sem_Disp is Decl_Item : Node_Id; begin - -- ??? The checks here for whether the type has been - -- frozen prior to the new body are not complete. It's - -- not simple to check frozenness at this point since - -- the body has already caused the type to be prematurely - -- frozen in Analyze_Declarations, but we're forced to - -- recheck this here because of the odd rule interpretation - -- that allows the overriding if the type wasn't frozen - -- prior to the body. The freezing action should probably - -- be delayed until after the spec is seen, but that's - -- a tricky change to the delicate freezing code. + -- ??? The checks here for whether the type has been frozen + -- prior to the new body are not complete. It's not simple + -- to check frozenness at this point since the body has + -- already caused the type to be prematurely frozen in + -- Analyze_Declarations, but we're forced to recheck this + -- here because of the odd rule interpretation that allows + -- the overriding if the type wasn't frozen prior to the + -- body. The freezing action should probably be delayed + -- until after the spec is seen, but that's a tricky + -- change to the delicate freezing code. -- Look at each declaration following the type up until the -- new subprogram body. If any of the declarations is a body @@ -1081,7 +1078,7 @@ package body Sem_Disp is elsif Is_Frozen (Subp) then -- The subprogram body declares a primitive operation. - -- if the subprogram is already frozen, we must update + -- If the subprogram is already frozen, we must update -- its dispatching information explicitly here. The -- information is taken from the overridden subprogram. -- We must also generate a cross-reference entry because @@ -1149,8 +1146,8 @@ package body Sem_Disp is -- (3.2.3(6)). Only report cases where the type and subprogram are -- in the same declaration list (by checking the enclosing parent -- declarations), to avoid spurious warnings on subprograms in - -- instance bodies when the type is declared in the instance spec but - -- hasn't been frozen by the instance body. + -- instance bodies when the type is declared in the instance spec + -- but hasn't been frozen by the instance body. elsif not Is_Frozen (Tagged_Type) and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp))) @@ -1643,12 +1640,12 @@ package body Sem_Disp is then Set_Alias (Old_Subp, Alias (Subp)); - -- The derived subprogram should inherit the abstractness - -- of the parent subprogram (except in the case of a function + -- The derived subprogram should inherit the abstractness of + -- the parent subprogram (except in the case of a function -- returning the type). This sets the abstractness properly - -- for cases where a private extension may have inherited - -- an abstract operation, but the full type is derived from - -- a descendant type and inherits a nonabstract version. + -- for cases where a private extension may have inherited an + -- abstract operation, but the full type is derived from a + -- descendant type and inherits a nonabstract version. if Etype (Subp) /= Tagged_Type then Set_Is_Abstract_Subprogram @@ -1946,9 +1943,9 @@ package body Sem_Disp is E := Homonym (E); end loop; - -- Search in the list of primitives of the type. Required to locate the - -- covering primitive if the covering primitive is not visible (for - -- example, non-visible inherited primitive of private type). + -- Search in the list of primitives of the type. Required to locate + -- the covering primitive if the covering primitive is not visible + -- (for example, non-visible inherited primitive of private type). El := First_Elmt (Primitive_Operations (Tagged_Type)); while Present (El) loop @@ -2275,8 +2272,8 @@ package body Sem_Disp is and then Has_Interfaces (Tagged_Type) then -- Ada 2005 (AI-251): Update the attribute alias of all the aliased - -- entities of the overridden primitive to reference New_Op, and also - -- propagate the proper value of Is_Abstract_Subprogram. Verify + -- entities of the overridden primitive to reference New_Op, and + -- also propagate the proper value of Is_Abstract_Subprogram. Verify -- that the new operation is subtype conformant with the interface -- operations that it implements (for operations inherited from the -- parent itself, this check is made when building the derived type). -- 2.7.4