+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
-- 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;
-- 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;
(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
-- 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
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
-- 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
-- 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
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)),
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
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.
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,
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.
-- 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 :=
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.
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,
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
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,
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
------------------------------------------------------------------------------
--- 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;
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,
-- "__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;
-- --
------------------------------------------------------------------------------
--- 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
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
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
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))
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
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;
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)
-- 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
-- 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);
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
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
-- (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)))
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
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
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).
projects / gcc.git / commitdiff