git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2012-07-12  Robert Dewar  <dewar@adacore.com>

	* sem_disp.adb: Minor reformatting
	* s-bytswa.ads: Minor comment update.

2012-07-12  Vincent Pucci  <pucci@adacore.com>

	* 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.

From-SVN: r189437
This commit is contained in:
Arnaud Charlet 2012-07-12 12:43:18 +02:00
parent 8926d36939
commit 03459f403e
7 changed files with 424 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gcc/ada/ChangeLog
View File

@ -1,3 +1,46 @@
2012-07-12 Robert Dewar <dewar@adacore.com>
* sem_disp.adb: Minor reformatting
* s-bytswa.ads: Minor comment update.
2012-07-12 Vincent Pucci <pucci@adacore.com>
* 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 <dewar@adacore.com>
* exp_attr.adb, exp_ch9.adb, sem_ch9.adb, exp_aggr.adb: Minor

208
gcc/ada/exp_ch9.adb
View File

@ -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
-- <original declarations before the object renaming declaration
-- of Comp>
-- 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;
--
-- <original delarations after the object renaming declaration
-- of Comp>
--
-- begin
-- <original statements>
-- 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;
-- <<L0>>
-- 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
-- <original statement>
-- else
-- goto L0;
@ -2991,10 +3001,16 @@ package body Exp_Ch9 is
-- function F (...) return ... is
-- <original declarations before the object renaming declaration
-- of Comp>
-- 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;
--
-- <original delarations after the object renaming declaration of
-- Comp>
--
-- begin
-- <original statements>
-- 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
-- <Stmt>;
-- 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
-- <Stmt>;
-- 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));
-- Expected_Comp : constant Comp_Type :=
-- Comp_Type
-- (System.Atomic_Primitives.Lock_Free_Read_N
-- (_Object.Comp'Address));
-- For procedures:
-- 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,

36
gcc/ada/rtsfind.ads
View File

@ -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,

128
gcc/ada/s-atopri.adb Normal file
View File

@ -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 --
-- <http://www.gnu.org/licenses/>. --
-- --
-- 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;

113
gcc/ada/s-atopri.ads
View File

@ -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;

5
gcc/ada/s-bytswa.ads
View File

@ -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

97
gcc/ada/sem_disp.adb
View File

@ -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).