+2012-05-15 Robert Dewar <dewar@adacore.com>
+
+ * g-comlin.adb, g-comlin.ads: Minor reformatting.
+
+2012-05-15 Vincent Pucci <pucci@adacore.com>
+
+ * aspects.adb, aspects.adb: Reordering of the Aspect_Idi list. New
+ aspect Aspect_Lock_Free.
+ * einfo.adb, einfo.ads: New flag Uses_Lock_Free (flag 188).
+ (Set_Uses_Lock_Free): New routine.
+ (Uses_Lock_Free): New routine.
+ * exp_ch7.adb (Is_Simple_Protected_Type): Return False for
+ lock-free implementation.
+ * exp_ch9.adb (Allows_Lock_Free_Implementation): Moved to Sem_Ch9.
+ (Build_Lock_Free_Unprotected_Subprogram_Body): Protected
+ procedure uses __sync_synchronise. Check both Object_Size
+ and Value_Size.
+ (Expand_N_Protected_Body): Lock_Free_Active
+ renames Lock_Free_On.
+ (Expand_N_Protected_Type_Declaration):
+ _Object field removed for lock-free implementation.
+ (Install_Private_Data_Declarations): Protection object removed
+ for lock-free implementation.
+ (Make_Initialize_Protection):
+ Protection object initialization removed for lock-free implementation.
+ * rtsfind.ads: RE_Atomic_Synchronize and RE_Relaxed added.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Aspect_Lock_Free
+ analysis added.
+ * sem_ch9.adb (Allows_Lock_Free_Implementation): New routine.
+ (Analyze_Protected_Body): Allows_Lock_Free_Implementation call added.
+ (Analyze_Protected_Type_Declaration):
+ Allows_Lock_Free_Implementation call added.
+ (Analyze_Single_Protected_Declaration): Second analysis of
+ aspects removed.
+ * s-atopri.ads: Header added.
+ (Atomic_Synchronize): New routine.
+
+2012-05-15 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch7.ads: Add comment.
+
2012-05-15 Hristian Kirtchev <kirtchev@adacore.com>
* a-calend.adb (Day_Of_Week): The routine once again treats
Aspect_Ada_2012 => Aspect_Ada_2005,
Aspect_Address => Aspect_Address,
Aspect_Alignment => Aspect_Alignment,
+ Aspect_All_Calls_Remote => Aspect_All_Calls_Remote,
Aspect_Asynchronous => Aspect_Asynchronous,
Aspect_Atomic => Aspect_Atomic,
Aspect_Atomic_Components => Aspect_Atomic_Components,
Aspect_Attach_Handler => Aspect_Attach_Handler,
Aspect_Bit_Order => Aspect_Bit_Order,
+ Aspect_Compiler_Unit => Aspect_Compiler_Unit,
Aspect_Component_Size => Aspect_Component_Size,
Aspect_Constant_Indexing => Aspect_Constant_Indexing,
Aspect_Contract_Case => Aspect_Contract_Case,
Aspect_Discard_Names => Aspect_Discard_Names,
Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate => Aspect_Predicate,
+ Aspect_Elaborate_Body => Aspect_Elaborate_Body,
Aspect_External_Tag => Aspect_External_Tag,
Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
Aspect_Implicit_Dereference => Aspect_Implicit_Dereference,
Aspect_Independent_Components => Aspect_Independent_Components,
Aspect_Inline => Aspect_Inline,
Aspect_Inline_Always => Aspect_Inline,
+ Aspect_Input => Aspect_Input,
Aspect_Interrupt_Handler => Aspect_Interrupt_Handler,
Aspect_Interrupt_Priority => Aspect_Interrupt_Priority,
- Aspect_Iterator_Element => Aspect_Iterator_Element,
- Aspect_All_Calls_Remote => Aspect_All_Calls_Remote,
- Aspect_Compiler_Unit => Aspect_Compiler_Unit,
- Aspect_Elaborate_Body => Aspect_Elaborate_Body,
- Aspect_Preelaborate => Aspect_Preelaborate,
- Aspect_Preelaborate_05 => Aspect_Preelaborate_05,
- Aspect_Pure => Aspect_Pure,
- Aspect_Pure_05 => Aspect_Pure_05,
- Aspect_Pure_12 => Aspect_Pure_12,
- Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
- Aspect_Remote_Types => Aspect_Remote_Types,
- Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order,
- Aspect_Shared_Passive => Aspect_Shared_Passive,
- Aspect_Universal_Data => Aspect_Universal_Data,
- Aspect_Input => Aspect_Input,
Aspect_Invariant => Aspect_Invariant,
+ Aspect_Iterator_Element => Aspect_Iterator_Element,
+ Aspect_Lock_Free => Aspect_Lock_Free,
Aspect_Machine_Radix => Aspect_Machine_Radix,
Aspect_No_Return => Aspect_No_Return,
Aspect_Object_Size => Aspect_Object_Size,
Aspect_Pre => Aspect_Pre,
Aspect_Precondition => Aspect_Pre,
Aspect_Predicate => Aspect_Predicate,
+ Aspect_Preelaborate => Aspect_Preelaborate,
+ Aspect_Preelaborate_05 => Aspect_Preelaborate_05,
Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
Aspect_Priority => Aspect_Priority,
+ Aspect_Pure => Aspect_Pure,
+ Aspect_Pure_05 => Aspect_Pure_05,
+ Aspect_Pure_12 => Aspect_Pure_12,
Aspect_Pure_Function => Aspect_Pure_Function,
Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,
+ Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
+ Aspect_Remote_Types => Aspect_Remote_Types,
Aspect_Read => Aspect_Read,
+ Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order,
Aspect_Shared => Aspect_Atomic,
+ Aspect_Shared_Passive => Aspect_Shared_Passive,
Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type,
Aspect_Size => Aspect_Size,
Aspect_Type_Invariant => Aspect_Invariant,
Aspect_Unchecked_Union => Aspect_Unchecked_Union,
Aspect_Universal_Aliasing => Aspect_Universal_Aliasing,
+ Aspect_Universal_Data => Aspect_Universal_Data,
Aspect_Unmodified => Aspect_Unmodified,
Aspect_Unreferenced => Aspect_Unreferenced,
Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects,
Aspect_Unreferenced, -- GNAT
Aspect_Unreferenced_Objects, -- GNAT
Aspect_Volatile,
- Aspect_Volatile_Components);
+ Aspect_Volatile_Components,
+
+ -- Aspects that have a static boolean value but don't correspond to
+ -- pragmas
+
+ Aspect_Lock_Free);
-- The following array indicates aspects that accept 'Class
Aspect_Dimension_System => True,
Aspect_Favor_Top_Level => True,
Aspect_Inline_Always => True,
+ Aspect_Lock_Free => True,
Aspect_Object_Size => True,
Aspect_Persistent_BSS => True,
Aspect_Predicate => True,
Aspect_Interrupt_Priority => Name_Interrupt_Priority,
Aspect_Invariant => Name_Invariant,
Aspect_Iterator_Element => Name_Iterator_Element,
+ Aspect_Lock_Free => Name_Lock_Free,
Aspect_Machine_Radix => Name_Machine_Radix,
Aspect_No_Return => Name_No_Return,
Aspect_Object_Size => Name_Object_Size,
-- Is_Ada_2005_Only Flag185
-- Is_Interface Flag186
-- Has_Constrained_Partial_View Flag187
+ -- Uses_Lock_Free Flag188
-- Is_Pure_Unit_Access_Type Flag189
-- Has_Specified_Stream_Input Flag190
-- Has_Anonymous_Master Flag253
-- Is_Implementation_Defined Flag254
- -- (unused) Flag188
-- (unused) Flag201
-----------------------
return Flag222 (Id);
end Used_As_Generic_Actual;
+ function Uses_Lock_Free (Id : E) return B is
+ begin
+ pragma Assert (Is_Protected_Type (Id));
+ return Flag188 (Id);
+ end Uses_Lock_Free;
+
function Uses_Sec_Stack (Id : E) return B is
begin
return Flag95 (Id);
Set_Node16 (Id, V);
end Set_Unset_Reference;
- procedure Set_Uses_Sec_Stack (Id : E; V : B := True) is
- begin
- Set_Flag95 (Id, V);
- end Set_Uses_Sec_Stack;
-
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is
begin
Set_Flag222 (Id, V);
end Set_Used_As_Generic_Actual;
+ procedure Set_Uses_Lock_Free (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Protected_Type);
+ Set_Flag188 (Id, V);
+ end Set_Uses_Lock_Free;
+
+ procedure Set_Uses_Sec_Stack (Id : E; V : B := True) is
+ begin
+ Set_Flag95 (Id, V);
+ end Set_Uses_Sec_Stack;
+
procedure Set_Warnings_Off (Id : E; V : B := True) is
begin
Set_Flag96 (Id, V);
-- Present in all entities, set if the entity is used as an argument to
-- a generic instantiation. Used to tune certain warning messages.
+-- Uses_Lock_Free (Flag188)
+-- Present in protected type entities. Set to True when the Lock Free
+-- implementation is used for the protected type. This implemenatation is
+-- based on atomic transactions and doesn't require anymore the use of
+-- Protection object (see System.Tasking.Protected_Objects).
+
-- Uses_Sec_Stack (Flag95)
-- Present in scope entities (blocks,functions, procedures, tasks,
-- entries). Set to True when secondary stack is used in this scope and
-- Stored_Constraint (Elist23)
-- Has_Interrupt_Handler (synth)
-- Sec_Stack_Needed_For_Return (Flag167) ???
+ -- Uses_Lock_Free (Flag188)
-- Uses_Sec_Stack (Flag95) ???
-- Has_Entries (synth)
-- Number_Entries (synth)
function Universal_Aliasing (Id : E) return B;
function Unset_Reference (Id : E) return N;
function Used_As_Generic_Actual (Id : E) return B;
+ function Uses_Lock_Free (Id : E) return B;
function Uses_Sec_Stack (Id : E) return B;
function Vax_Float (Id : E) return B;
function Warnings_Off (Id : E) return B;
procedure Set_Universal_Aliasing (Id : E; V : B := True);
procedure Set_Unset_Reference (Id : E; V : N);
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True);
+ procedure Set_Uses_Lock_Free (Id : E; V : B := True);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
procedure Set_Warnings_Off (Id : E; V : B := True);
procedure Set_Warnings_Off_Used (Id : E; V : B := True);
pragma Inline (Universal_Aliasing);
pragma Inline (Unset_Reference);
pragma Inline (Used_As_Generic_Actual);
+ pragma Inline (Uses_Lock_Free);
pragma Inline (Uses_Sec_Stack);
pragma Inline (Warnings_Off);
pragma Inline (Warnings_Off_Used);
pragma Inline (Set_Universal_Aliasing);
pragma Inline (Set_Unset_Reference);
pragma Inline (Set_Used_As_Generic_Actual);
+ pragma Inline (Set_Uses_Lock_Free);
pragma Inline (Set_Uses_Sec_Stack);
pragma Inline (Set_Warnings_Off);
pragma Inline (Set_Warnings_Off_Used);
begin
return
Is_Protected_Type (T)
+ and then not Uses_Lock_Free (T)
and then not Has_Entries (T)
and then Is_RTE (Find_Protection_Type (T), RE_Protection);
end Is_Simple_Protected_Type;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
function Is_Simple_Protected_Type (T : Entity_Id) return Boolean;
-- Determine whether T denotes a protected type without entires whose
-- _object field is of type System.Tasking.Protected_Objects.Protection.
+ -- Something wrong here, implementation was changed to test Lock_Free
+ -- but this spec does not mention that ???
--------------------------------
-- Transient Scope Management --
with Atree; use Atree;
with Checks; use Checks;
-with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch9; use Sem_Ch9;
with Sem_Ch11; use Sem_Ch11;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
Entry_Family_Bound : constant Int := 2**16;
- ------------------------------
- -- Lock Free Data Structure --
- ------------------------------
-
- -- A lock-free subprogram is a protected routine which references a unique
- -- protected scalar component and does not contain statements that cause
- -- side effects. Due to this restricted behavior, all references to shared
- -- data from within the subprogram can be synchronized through the use of
- -- atomic operations rather than relying on locks.
-
- type Lock_Free_Subprogram is record
- Sub_Body : Node_Id;
- -- Reference to the body of a protected subprogram which meets the lock-
- -- free requirements.
-
- Comp_Id : Entity_Id;
- -- Reference to the scalar component referenced from within Sub_Body
- end record;
-
- -- This table establishes a relation between a protected subprogram body
- -- and a unique component it references. The table is used when building
- -- the lock-free versions of a protected subprogram body.
-
- package Lock_Free_Subprogram_Table is new Table.Table (
- Table_Component_Type => Lock_Free_Subprogram,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 5,
- Table_Increment => 5,
- Table_Name => "Lock_Free_Subprogram_Table");
-
-----------------------
-- Local Subprograms --
-----------------------
-- Decls is the list of declarations to be enhanced.
-- Ent is the entity for the original entry body.
- function Allows_Lock_Free_Implementation (N : Node_Id) return Boolean;
- -- Given a protected body N, return True if N satisfies the following list
- -- of lock-free restrictions:
- --
- -- 1) Protected type
- -- May not contain entries
- -- May contain only scalar components
- -- Component types must support atomic compare and exchange
- --
- -- 2) Protected subprograms
- -- May not have side effects
- -- May not contain loop statements or procedure calls
- -- Function calls and attribute references must be static
-
function Build_Accept_Body (Astat : Node_Id) return Node_Id;
-- Transform accept statement into a block with added exception handler.
-- Used both for simple accept statements and for accept alternatives in
Prepend_To (Decls, Decl);
end Add_Object_Pointer;
- -------------------------------------
- -- Allows_Lock_Free_Implementation --
- -------------------------------------
-
- function Allows_Lock_Free_Implementation (N : Node_Id) return Boolean is
- Spec : constant Entity_Id := Corresponding_Spec (N);
- Prot_Def : constant Node_Id := Protected_Definition (Parent (Spec));
- Priv_Decls : constant List_Id := Private_Declarations (Prot_Def);
-
- function Satisfies_Lock_Free_Requirements
- (Sub_Body : Node_Id) return Boolean;
- -- Return True if protected subprogram body Sub_Body satisfies all
- -- requirements of a lock-free implementation.
-
- --------------------------------------
- -- Satisfies_Lock_Free_Requirements --
- --------------------------------------
-
- function Satisfies_Lock_Free_Requirements
- (Sub_Body : Node_Id) return Boolean
- is
- Comp : Entity_Id := Empty;
- -- Track the current component which the body references
-
- function Check_Node (N : Node_Id) return Traverse_Result;
- -- Check that node N meets the lock free restrictions
-
- ----------------
- -- Check_Node --
- ----------------
-
- function Check_Node (N : Node_Id) return Traverse_Result is
- begin
- -- Function calls and attribute references must be static
- -- ??? what about side-effects
-
- if Nkind_In (N, N_Attribute_Reference, N_Function_Call)
- and then not Is_Static_Expression (N)
- then
- return Abandon;
-
- -- Loop statements and procedure calls are prohibited
-
- elsif Nkind_In (N, N_Loop_Statement,
- N_Procedure_Call_Statement)
- then
- return Abandon;
-
- -- References
-
- elsif Nkind (N) = N_Identifier
- and then Present (Entity (N))
- then
- declare
- Id : constant Entity_Id := Entity (N);
- Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body);
-
- begin
- -- Prohibit references to non-constant entities outside the
- -- protected subprogram scope.
-
- if Ekind (Id) in Assignable_Kind
- and then not Scope_Within_Or_Same (Scope (Id), Sub_Id)
- and then not Scope_Within_Or_Same (Scope (Id),
- Protected_Body_Subprogram (Sub_Id))
- then
- return Abandon;
-
- -- A protected subprogram may reference only one component
- -- of the protected type.
-
- elsif Ekind_In (Id, E_Constant, E_Variable)
- and then Present (Prival_Link (Id))
- then
- declare
- Comp_Decl : constant Node_Id :=
- Parent (Prival_Link (Id));
- begin
- if Nkind (Comp_Decl) = N_Component_Declaration
- and then Is_List_Member (Comp_Decl)
- and then List_Containing (Comp_Decl) = Priv_Decls
- then
- if No (Comp) then
- Comp := Prival_Link (Id);
-
- -- Check if another protected component has already
- -- been accessed by the subprogram body.
-
- elsif Comp /= Prival_Link (Id) then
- return Abandon;
- end if;
- end if;
- end;
- end if;
- end;
- end if;
-
- return OK;
- end Check_Node;
-
- function Check_All_Nodes is new Traverse_Func (Check_Node);
-
- -- Start of processing for Satisfies_Lock_Free_Requirements
-
- begin
- if Check_All_Nodes (Sub_Body) = OK then
-
- -- Establish a relation between the subprogram body and the unique
- -- protected component it references.
-
- if Present (Comp) then
- Lock_Free_Subprogram_Table.Append
- (Lock_Free_Subprogram'(Sub_Body, Comp));
- end if;
-
- return True;
- else
- return False;
- end if;
- end Satisfies_Lock_Free_Requirements;
-
- -- Local variables
-
- Decls : constant List_Id := Declarations (N);
- Vis_Decls : constant List_Id := Visible_Declarations (Prot_Def);
-
- Comp_Id : Entity_Id;
- Comp_Size : Int;
- Comp_Type : Entity_Id;
- Decl : Node_Id;
- Has_Component : Boolean := False;
-
- -- Start of processing for Allows_Lock_Free_Implementation
-
- begin
- -- The lock-free implementation is currently enabled through a debug
- -- flag.
-
- if not Debug_Flag_9 then
- return False;
- end if;
-
- -- Examine the visible declarations. Entries and entry families are not
- -- allowed by the lock-free restrictions.
-
- Decl := First (Vis_Decls);
- while Present (Decl) loop
- if Nkind (Decl) = N_Entry_Declaration then
- return False;
- end if;
-
- Next (Decl);
- end loop;
-
- -- Examine the private declarations
-
- Decl := First (Priv_Decls);
- while Present (Decl) loop
-
- -- The protected type must define at least one scalar component
-
- if Nkind (Decl) = N_Component_Declaration then
- Has_Component := True;
-
- Comp_Id := Defining_Identifier (Decl);
- Comp_Type := Etype (Comp_Id);
-
- if not Is_Scalar_Type (Comp_Type) then
- return False;
- end if;
-
- Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type)));
-
- -- Check that the size of the component is 8, 16, 32 or 64 bits
-
- case Comp_Size is
- when 8 | 16 | 32 | 64 =>
- null;
- when others =>
- return False;
- end case;
-
- -- Entries and entry families are not allowed
-
- elsif Nkind (Decl) = N_Entry_Declaration then
- return False;
- end if;
-
- Next (Decl);
- end loop;
-
- -- At least one scalar component must be present
-
- if not Has_Component then
- return False;
- end if;
-
- -- Ensure that all protected subprograms meet the restrictions of the
- -- lock-free implementation.
-
- Decl := First (Decls);
- while Present (Decl) loop
- if Nkind (Decl) = N_Subprogram_Body
- and then not Satisfies_Lock_Free_Requirements (Decl)
- then
- return False;
- end if;
-
- Next (Decl);
- end loop;
-
- return True;
- end Allows_Lock_Free_Implementation;
-
-----------------------
-- Build_Accept_Body --
-----------------------
-- begin
-- loop
-- declare
- -- Saved_Comp : constant ... := Atomic_Load (Comp'Address);
+ -- Saved_Comp : constant ... :=
+ -- Atomic_Load (Comp'Address, Relaxed);
-- Current_Comp : ... := Saved_Comp;
-- begin
-- <original statements>
if Present (Comp) then
declare
- Comp_Typ : constant Entity_Id := Etype (Comp);
- Typ_Size : constant Int := UI_To_Int (Esize (Comp_Typ));
+ 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;
+ Typ_Size : Int;
Unsigned : Entity_Id;
begin
+ -- Get the type size
+
+ if Known_Esize (Comp_Type) then
+ Typ_Size := UI_To_Int (Esize (Comp_Type));
+
+ -- If the Esize (Object_Size) is unknown at compile-time, look at
+ -- the RM_Size (Value_Size) since it may have been set by an
+ -- explicit representation clause.
+
+ else
+ Typ_Size := UI_To_Int (RM_Size (Comp_Type));
+ end if;
+
-- Retrieve all relevant atomic routines and types
case Typ_Size is
end case;
-- Generate:
- -- Saved_Comp : constant Comp_Typ :=
- -- Comp_Typ (Atomic_Load (Comp'Address));
+ -- For functions:
+
+ -- Saved_Comp : constant Comp_Type :=
+ -- Comp_Type (Atomic_Load (Comp'Address));
+
+ -- For procedures:
+
+ -- Saved_Comp : constant Comp_Type :=
+ -- Comp_Type (Atomic_Load (Comp'Address),
+ -- Relaxed);
Saved_Comp :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Comp), Suffix => "_saved"));
+ Load_Params := New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Comp, Loc),
+ 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,
- Object_Definition => New_Reference_To (Comp_Typ, Loc),
+ Object_Definition => New_Reference_To (Comp_Type, Loc),
Expression =>
- Unchecked_Convert_To (Comp_Typ,
+ Unchecked_Convert_To (Comp_Type,
Make_Function_Call (Loc,
Name => New_Reference_To (Load, Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Comp, Loc),
- Attribute_Name => Name_Address)))));
+ Parameter_Associations => Load_Params)));
-- Protected procedures
Block_Decls := New_List (Decl);
-- Generate:
- -- Current_Comp : Comp_Typ := Saved_Comp;
+ -- Current_Comp : Comp_Type := Saved_Comp;
Current_Comp :=
Make_Defining_Identifier (Loc,
Append_To (Block_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Current_Comp,
- Object_Definition => New_Reference_To (Comp_Typ, Loc),
+ Object_Definition => New_Reference_To (Comp_Type, Loc),
Expression => New_Reference_To (Saved_Comp, Loc)));
-- Protected function
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,
Loc : constant Source_Ptr := Sloc (N);
Pid : constant Entity_Id := Corresponding_Spec (N);
- Lock_Free_On : constant Boolean := Allows_Lock_Free_Implementation (N);
+ Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid);
-- This flag indicates whether the lock free implementation is active
Current_Node : Node_Id;
if not Is_Eliminated (Defining_Entity (Op_Body))
and then not Is_Eliminated (Corresponding_Spec (Op_Body))
then
- if Lock_Free_On then
+ if Lock_Free_Active then
New_Op_Body :=
Build_Lock_Free_Unprotected_Subprogram_Body
(Op_Body, Pid);
-- declaration in the protected body itself.
if Present (Corresponding_Spec (Op_Body)) then
- if Lock_Free_On then
+ if Lock_Free_Active then
New_Op_Body :=
Build_Lock_Free_Protected_Subprogram_Body
(Op_Body, Pid, Specification (New_Op_Body));
-- the specs refer to this type.
procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Prot_Typ : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Prot_Typ : constant Entity_Id := Defining_Identifier (N);
+
+ Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ);
+ -- This flag indicates whether the lock free implementation is active
- Pdef : constant Node_Id := Protected_Definition (N);
+ Pdef : constant Node_Id := Protected_Definition (N);
-- This contains two lists; one for visible and one for private decls
Rec_Decl : Node_Id;
Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
- -- Prepend the _Object field with the right type to the component list.
- -- We need to compute the number of entries, and in some cases the
- -- number of Attach_Handler pragmas.
-
- declare
- Ritem : Node_Id;
- Num_Attach_Handler : Int := 0;
- Protection_Subtype : Node_Id;
- Entry_Count_Expr : constant Node_Id :=
- Build_Entry_Count_Expression
- (Prot_Typ, Cdecls, Loc);
-
- begin
- -- Could this be simplified using Corresponding_Runtime_Package???
-
- if Has_Attach_Handler (Prot_Typ) then
- Ritem := First_Rep_Item (Prot_Typ);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Attach_Handler
- then
- Num_Attach_Handler := Num_Attach_Handler + 1;
- end if;
-
- Next_Rep_Item (Ritem);
- end loop;
-
- if Restricted_Profile then
- if Has_Entries (Prot_Typ) then
- Protection_Subtype :=
- New_Reference_To (RTE (RE_Protection_Entry), Loc);
- else
- Protection_Subtype :=
- New_Reference_To (RTE (RE_Protection), Loc);
- end if;
- else
- Protection_Subtype :=
- Make_Subtype_Indication
- (Sloc => Loc,
- Subtype_Mark =>
- New_Reference_To
- (RTE (RE_Static_Interrupt_Protection), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (
- Sloc => Loc,
- Constraints => New_List (
- Entry_Count_Expr,
- Make_Integer_Literal (Loc, Num_Attach_Handler))));
- end if;
-
- elsif Has_Interrupt_Handler (Prot_Typ)
- and then not Restriction_Active (No_Dynamic_Attachment)
- then
- Protection_Subtype :=
- Make_Subtype_Indication (
- Sloc => Loc,
- Subtype_Mark => New_Reference_To
- (RTE (RE_Dynamic_Interrupt_Protection), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (
- Sloc => Loc,
- Constraints => New_List (Entry_Count_Expr)));
-
- -- Type has explicit entries or generated primitive entry wrappers
-
- elsif Has_Entries (Prot_Typ)
- or else (Ada_Version >= Ada_2005
- and then Present (Interface_List (N)))
- then
- case Corresponding_Runtime_Package (Prot_Typ) is
- when System_Tasking_Protected_Objects_Entries =>
- Protection_Subtype :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protection_Entries), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (
- Sloc => Loc,
- Constraints => New_List (Entry_Count_Expr)));
-
- when System_Tasking_Protected_Objects_Single_Entry =>
- Protection_Subtype :=
- New_Reference_To (RTE (RE_Protection_Entry), Loc);
-
- when others =>
- raise Program_Error;
- end case;
-
- else
- Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc);
- end if;
-
- Object_Comp :=
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uObject),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => True,
- Subtype_Indication => Protection_Subtype));
- end;
-
pragma Assert (Present (Pdef));
-- Add private field components
end loop;
end if;
- -- Put the _Object component after the private component so that it
- -- be finalized early as required by 9.4 (20)
+ -- Except for the lock-free implementation, prepend the _Object field
+ -- with the right type to the component list. We need to compute the
+ -- number of entries, and in some cases the number of Attach_Handler
+ -- pragmas.
+
+ if not Lock_Free_Active then
+ declare
+ Ritem : Node_Id;
+ Num_Attach_Handler : Int := 0;
+ Protection_Subtype : Node_Id;
+ Entry_Count_Expr : constant Node_Id :=
+ Build_Entry_Count_Expression
+ (Prot_Typ, Cdecls, Loc);
+
+ begin
+ -- Could this be simplified using Corresponding_Runtime_Package???
+
+ if Has_Attach_Handler (Prot_Typ) then
+ Ritem := First_Rep_Item (Prot_Typ);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Pragma
+ and then Pragma_Name (Ritem) = Name_Attach_Handler
+ then
+ Num_Attach_Handler := Num_Attach_Handler + 1;
+ end if;
+
+ Next_Rep_Item (Ritem);
+ end loop;
+
+ if Restricted_Profile then
+ if Has_Entries (Prot_Typ) then
+ Protection_Subtype :=
+ New_Reference_To (RTE (RE_Protection_Entry), Loc);
+ else
+ Protection_Subtype :=
+ New_Reference_To (RTE (RE_Protection), Loc);
+ end if;
+ else
+ Protection_Subtype :=
+ Make_Subtype_Indication
+ (Sloc => Loc,
+ Subtype_Mark =>
+ New_Reference_To
+ (RTE (RE_Static_Interrupt_Protection), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (
+ Sloc => Loc,
+ Constraints => New_List (
+ Entry_Count_Expr,
+ Make_Integer_Literal (Loc, Num_Attach_Handler))));
+ end if;
+
+ elsif Has_Interrupt_Handler (Prot_Typ)
+ and then not Restriction_Active (No_Dynamic_Attachment)
+ then
+ Protection_Subtype :=
+ Make_Subtype_Indication (
+ Sloc => Loc,
+ Subtype_Mark => New_Reference_To
+ (RTE (RE_Dynamic_Interrupt_Protection), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (
+ Sloc => Loc,
+ Constraints => New_List (Entry_Count_Expr)));
+
+ -- Type has explicit entries or generated primitive entry wrappers
- Append_To (Cdecls, Object_Comp);
+ elsif Has_Entries (Prot_Typ)
+ or else (Ada_Version >= Ada_2005
+ and then Present (Interface_List (N)))
+ then
+ case Corresponding_Runtime_Package (Prot_Typ) is
+ when System_Tasking_Protected_Objects_Entries =>
+ Protection_Subtype :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protection_Entries),
+ Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (
+ Sloc => Loc,
+ Constraints => New_List (Entry_Count_Expr)));
+
+ when System_Tasking_Protected_Objects_Single_Entry =>
+ Protection_Subtype :=
+ New_Reference_To (RTE (RE_Protection_Entry), Loc);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ else
+ Protection_Subtype :=
+ New_Reference_To (RTE (RE_Protection), Loc);
+ end if;
+
+ Object_Comp :=
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uObject),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => True,
+ Subtype_Indication => Protection_Subtype));
+ end;
+
+ -- Put the _Object component after the private component so that it
+ -- be finalized early as required by 9.4 (20)
+
+ Append_To (Cdecls, Object_Comp);
+ end if;
Insert_After (Current_Node, Rec_Decl);
Current_Node := Rec_Decl;
end if;
-- Step 2: Create the Protection object and build its declaration for
- -- any protected entry (family) of subprogram.
+ -- any protected entry (family) of subprogram. Note for the lock-free
+ -- implementation, the Protection object is not needed anymore.
- if Is_Protected then
+ if Is_Protected
+ and then not Uses_Lock_Free (Conc_Typ)
+ then
declare
Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
Prot_Typ : RE_Id;
Args := New_List;
- -- Object parameter. This is a pointer to the object of type
- -- Protection used by the GNARL to control the protected object.
-
- Append_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access));
-
- -- Priority parameter. Set to Unspecified_Priority unless there is a
- -- priority pragma, in which case we take the value from the pragma,
- -- or there is an interrupt pragma and no priority pragma, and we
- -- set the ceiling to Interrupt_Priority'Last, an implementation-
- -- defined value, see D.3(10).
-
- if Present (Pdef)
- and then Has_Pragma_Priority (Pdef)
- then
- declare
- Prio : constant Node_Id :=
- Expression
- (First
- (Pragma_Argument_Associations
- (Find_Task_Or_Protected_Pragma
- (Pdef, Name_Priority))));
- Temp : Entity_Id;
-
- begin
- -- If priority is a static expression, then we can duplicate it
- -- with no problem and simply append it to the argument list.
-
- if Is_Static_Expression (Prio) then
- Append_To (Args,
- Duplicate_Subexpr_No_Checks (Prio));
-
- -- Otherwise, the priority may be a per-object expression, if it
- -- depends on a discriminant of the type. In this case, create
- -- local variable to capture the expression. Note that it is
- -- really necessary to create this variable explicitly. It might
- -- be thought that removing side effects would the appropriate
- -- approach, but that could generate declarations improperly
- -- placed in the enclosing scope.
-
- -- Note: Use System.Any_Priority as the expected type for the
- -- non-static priority expression, in case the expression has not
- -- been analyzed yet (as occurs for example with pragma
- -- Interrupt_Priority).
-
- else
- Temp := Make_Temporary (Loc, 'R', Prio);
- Append_To (L,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Any_Priority), Loc),
- Expression => Relocate_Node (Prio)));
-
- Append_To (Args, New_Occurrence_Of (Temp, Loc));
- end if;
- end;
+ -- For lock-free implementation, skip initializations of the Protection
+ -- object.
- -- When no priority is specified but an xx_Handler pragma is, we default
- -- to System.Interrupts.Default_Interrupt_Priority, see D.3(10).
+ if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
+ -- Object parameter. This is a pointer to the object of type
+ -- Protection used by the GNARL to control the protected object.
- elsif Has_Attach_Handler (Ptyp)
- or else Has_Interrupt_Handler (Ptyp)
- then
Append_To (Args,
- New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access));
+
+ -- Priority parameter. Set to Unspecified_Priority unless there is a
+ -- priority pragma, in which case we take the value from the pragma,
+ -- or there is an interrupt pragma and no priority pragma, and we
+ -- set the ceiling to Interrupt_Priority'Last, an implementation-
+ -- defined value, see D.3(10).
+
+ if Present (Pdef)
+ and then Has_Pragma_Priority (Pdef)
+ then
+ declare
+ Prio : constant Node_Id :=
+ Expression
+ (First
+ (Pragma_Argument_Associations
+ (Find_Task_Or_Protected_Pragma
+ (Pdef, Name_Priority))));
+ Temp : Entity_Id;
- -- Normal case, no priority or xx_Handler specified, default priority
+ begin
+ -- If priority is a static expression, then we can duplicate it
+ -- with no problem and simply append it to the argument list.
- else
- Append_To (Args,
- New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
- end if;
+ if Is_Static_Expression (Prio) then
+ Append_To (Args,
+ Duplicate_Subexpr_No_Checks (Prio));
- -- Test for Compiler_Info parameter. This parameter allows entry body
- -- procedures and barrier functions to be called from the runtime. It
- -- is a pointer to the record generated by the compiler to represent
- -- the protected object.
+ -- Otherwise, the priority may be a per-object expression, if
+ -- it depends on a discriminant of the type. In this case,
+ -- create local variable to capture the expression. Note that
+ -- it is really necessary to create this variable explicitly.
+ -- It might be thought that removing side effects would the
+ -- appropriate approach, but that could generate declarations
+ -- improperly placed in the enclosing scope.
- -- A protected type without entries that covers an interface and
- -- overrides the abstract routines with protected procedures is
- -- considered equivalent to a protected type with entries in the
- -- context of dispatching select statements.
+ -- Note: Use System.Any_Priority as the expected type for the
+ -- non-static priority expression, in case the expression has
+ -- not been analyzed yet (as occurs for example with pragma
+ -- Interrupt_Priority).
- if Has_Entry
- or else Has_Interfaces (Protect_Rec)
- or else
- ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp))
- and then not Restriction_Active (No_Dynamic_Attachment))
- then
- declare
- Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
+ else
+ Temp := Make_Temporary (Loc, 'R', Prio);
+ Append_To (L,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Any_Priority), Loc),
+ Expression => Relocate_Node (Prio)));
+
+ Append_To (Args, New_Occurrence_Of (Temp, Loc));
+ end if;
+ end;
- Called_Subp : RE_Id;
+ -- When no priority is specified but an xx_Handler pragma is, we
+ -- default to System.Interrupts.Default_Interrupt_Priority, see
+ -- D.3(10).
- begin
- case Pkg_Id is
- when System_Tasking_Protected_Objects_Entries =>
- Called_Subp := RE_Initialize_Protection_Entries;
+ elsif Has_Attach_Handler (Ptyp)
+ or else Has_Interrupt_Handler (Ptyp)
+ then
+ Append_To (Args,
+ New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
- when System_Tasking_Protected_Objects =>
- Called_Subp := RE_Initialize_Protection;
+ -- Normal case, no priority or xx_Handler specified, default priority
- when System_Tasking_Protected_Objects_Single_Entry =>
- Called_Subp := RE_Initialize_Protection_Entry;
+ else
+ Append_To (Args,
+ New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
+ end if;
- when others =>
- raise Program_Error;
- end case;
+ -- Test for Compiler_Info parameter. This parameter allows entry body
+ -- procedures and barrier functions to be called from the runtime. It
+ -- is a pointer to the record generated by the compiler to represent
+ -- the protected object.
+
+ -- A protected type without entries that covers an interface and
+ -- overrides the abstract routines with protected procedures is
+ -- considered equivalent to a protected type with entries in the
+ -- context of dispatching select statements.
+
+ if Has_Entry
+ or else Has_Interfaces (Protect_Rec)
+ or else
+ ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp))
+ and then not Restriction_Active (No_Dynamic_Attachment))
+ then
+ declare
+ Pkg_Id : constant RTU_Id :=
+ Corresponding_Runtime_Package (Ptyp);
- if Has_Entry
- or else not Restricted
- or else Has_Interfaces (Protect_Rec)
- then
- Append_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Attribute_Name => Name_Address));
- end if;
+ Called_Subp : RE_Id;
- -- Entry_Bodies parameter. This is a pointer to an array of
- -- pointers to the entry body procedures and barrier functions of
- -- the object. If the protected type has no entries this object
- -- will not exist, in this case, pass a null.
+ begin
+ case Pkg_Id is
+ when System_Tasking_Protected_Objects_Entries =>
+ Called_Subp := RE_Initialize_Protection_Entries;
- if Has_Entry then
- P_Arr := Entry_Bodies_Array (Ptyp);
+ when System_Tasking_Protected_Objects =>
+ Called_Subp := RE_Initialize_Protection;
- Append_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (P_Arr, Loc),
- Attribute_Name => Name_Unrestricted_Access));
+ when System_Tasking_Protected_Objects_Single_Entry =>
+ Called_Subp := RE_Initialize_Protection_Entry;
+
+ when others =>
+ raise Program_Error;
+ end case;
- if Pkg_Id = System_Tasking_Protected_Objects_Entries then
+ if Has_Entry
+ or else not Restricted
+ or else Has_Interfaces (Protect_Rec)
+ then
+ Append_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Attribute_Name => Name_Address));
+ end if;
- -- Find index mapping function (clumsy but ok for now)
+ -- Entry_Bodies parameter. This is a pointer to an array of
+ -- pointers to the entry body procedures and barrier functions
+ -- of the object. If the protected type has no entries this
+ -- object will not exist, in this case, pass a null.
- while Ekind (P_Arr) /= E_Function loop
- Next_Entity (P_Arr);
- end loop;
+ if Has_Entry then
+ P_Arr := Entry_Bodies_Array (Ptyp);
Append_To (Args,
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (P_Arr, Loc),
+ Prefix => New_Reference_To (P_Arr, Loc),
Attribute_Name => Name_Unrestricted_Access));
- -- Build_Entry_Names generation flag. When set to true, the
- -- runtime will allocate an array to hold the string names
- -- of protected entries.
+ if Pkg_Id = System_Tasking_Protected_Objects_Entries then
- if not Restricted_Profile then
- if Entry_Names_OK then
- Append_To (Args,
- New_Reference_To (Standard_True, Loc));
- else
- Append_To (Args,
- New_Reference_To (Standard_False, Loc));
+ -- Find index mapping function (clumsy but ok for now)
+
+ while Ekind (P_Arr) /= E_Function loop
+ Next_Entity (P_Arr);
+ end loop;
+
+ Append_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (P_Arr, Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+
+ -- Build_Entry_Names generation flag. When set to true,
+ -- the runtime will allocate an array to hold the string
+ -- names of protected entries.
+
+ if not Restricted_Profile then
+ if Entry_Names_OK then
+ Append_To (Args,
+ New_Reference_To (Standard_True, Loc));
+ else
+ Append_To (Args,
+ New_Reference_To (Standard_False, Loc));
+ end if;
end if;
end if;
- end if;
- elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
- Append_To (Args, Make_Null (Loc));
+ elsif Pkg_Id =
+ System_Tasking_Protected_Objects_Single_Entry
+ then
+ Append_To (Args, Make_Null (Loc));
- elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
- Append_To (Args, Make_Null (Loc));
- Append_To (Args, Make_Null (Loc));
- Append_To (Args, New_Reference_To (Standard_False, Loc));
- end if;
+ elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
+ Append_To (Args, Make_Null (Loc));
+ Append_To (Args, Make_Null (Loc));
+ Append_To (Args, New_Reference_To (Standard_False, Loc));
+ end if;
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (Called_Subp), Loc),
+ Parameter_Associations => Args));
+ end;
+ else
Append_To (L,
Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (Called_Subp), Loc),
+ Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
Parameter_Associations => Args));
- end;
- else
- Append_To (L,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
- Parameter_Associations => Args));
+ end if;
end if;
if Has_Attach_Handler (Ptyp) then
Parameter_Associations => Args));
else
- -- First, prepends the _object argument
+ if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
+ -- First, prepends the _object argument
- Prepend_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access));
+ Prepend_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access));
+ end if;
-- Then, insert call to Install_Handlers
begin
if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def
- (Def, Switch, Long_Switch, Help, Section, Argument);
+ (Def, Switch, Long_Switch, Help, Section, Argument);
Add (Config, Def);
end if;
end Define_Switch;
begin
if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def
- (Def, Switch, Long_Switch, Help, Section, Argument);
+ (Def, Switch, Long_Switch, Help, Section, Argument);
Def.Integer_Output := Output.all'Unchecked_Access;
Def.Integer_Default := Default;
Def.Integer_Initial := Initial;
begin
if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def
- (Def, Switch, Long_Switch, Help, Section, Argument);
+ (Def, Switch, Long_Switch, Help, Section, Argument);
Def.String_Output := Output.all'Unchecked_Access;
Add (Config, Def);
end if;
end if;
end if;
- else -- Long_Switch necessarily not null
+ -- Def.Switch is null (Long_Switch must be non-null)
+
+ else
Decompose_Switch (Def.Long_Switch.all, P2, Last2);
Append (Result,
Def.Long_Switch (Def.Long_Switch'First .. Last2));
-- ...
-- Specifying the help message is optional, but makes it easy to then call
--- the function
+-- the function:
+
-- Display_Help (Config);
+
-- that will display a properly formatted help message for your application,
-- listing all possible switches. That way you have a single place in which
-- to maintain the list of switches and their meaning, rather than maintaining
-- both the string to pass to Getopt and a subprogram to display the help.
-- Both will properly stay synchronized.
--- Once you have this Config, you just have to call
+-- Once you have this Config, you just have to call:
+
-- Getopt (Config, Callback'Access);
+
-- to parse the command line. The Callback will be called for each switch
-- found on the command line (in the case of our example, that is "-gnatwu"
-- and then "-gnatwv", not "-gnatwa" itself). This simplifies command line
-- Optimization : aliased Integer;
-- Verbose : aliased Boolean;
---
+
-- Define_Switch (Config, Verbose'Access,
-- "-v", Long_Switch => "--verbose",
-- Help => "Output extra verbose information");
-- Define_Switch (Config, Optimization'Access,
-- "-O?", Help => "Optimization level");
---
+
-- Getopt (Config); -- No callback
-- Since all switches are handled automatically, we don't even need to pass
-- Some command line arguments can have parameters, which on a command line
-- appear as a separate argument that must immediately follow the switch.
-- Since the subprograms in this package will reorganize the switches to group
--- them, you need to indicate what is a command line
--- parameter, and what is a switch argument.
+-- them, you need to indicate what is a command line parameter, and what is a
+-- switch argument.
-- This is done by passing an extra argument to Add_Switch, as in:
Stop_At_First_Non_Switch : Boolean := False;
Section_Delimiters : String := "");
-- The first procedure resets the internal state of the package to prepare
- -- to rescan the parameters. It does not need to be called before the first
- -- use of Getopt (but it could be), but it must be called if you want to
- -- start rescanning the command line parameters from the start. The
- -- optional parameter Switch_Char can be used to reset the switch
+ -- to rescan the parameters. It does not need to be called before the
+ -- first use of Getopt (but it could be), but it must be called if you
+ -- want to start rescanning the command line parameters from the start.
+ -- The optional parameter Switch_Char can be used to reset the switch
-- character, e.g. to '/' for use in DOS-like systems.
--
- -- The second subprogram initializes a parser that takes its arguments from
- -- an array of strings rather than directly from the command line. In this
- -- case, the parser is responsible for freeing the strings stored in
+ -- The second subprogram initializes a parser that takes its arguments
+ -- from an array of strings rather than directly from the command line. In
+ -- this case, the parser is responsible for freeing the strings stored in
-- Command_Line. If you pass null to Command_Line, this will in fact create
-- a second parser for Ada.Command_Line, which doesn't share any data with
- -- the default parser. This parser must be free-ed.
+ -- the default parser. This parser must be free'ed.
--
-- The optional parameter Stop_At_First_Non_Switch indicates if Getopt is
-- to look for switches on the whole command line, or if it has to stop as
-- spaces.
--
-- Example
- -- Getopt ("a b", Concatenate => False)
- -- If the command line is '-ab', exception Invalid_Switch will be
- -- raised and Full_Switch will return "ab".
+ -- Getopt ("a b", Concatenate => False)
+ -- If the command line is '-ab', exception Invalid_Switch will be
+ -- raised and Full_Switch will return "ab".
function Get_Argument
(Do_Expansion : Boolean := False;
-- The section name should not include the leading '-'. So for instance in
-- the case of gnatmake we would use:
--
- -- Define_Section (Config, "cargs");
- -- Define_Section (Config, "bargs");
+ -- Define_Section (Config, "cargs");
+ -- Define_Section (Config, "bargs");
procedure Define_Alias
(Config : in out Command_Line_Configuration;
--
-- Switch and Long_Switch (when specified) are aliases and can be used
-- interchangeably. There is no check that they both take an argument or
- -- both take no argument.
- -- Switch can be set to "*" to indicate that any switch is supported (in
- -- which case Getopt will return '*', see its documentation).
+ -- both take no argument. Switch can be set to "*" to indicate that any
+ -- switch is supported (in which case Getopt will return '*', see its
+ -- documentation).
--
-- Help is used by the Display_Help procedure to describe the supported
-- switches.
-- See Define_Switch for a description of the parameters.
-- When the switch is found on the command line, Getopt will set
-- Output.all to Value.
+ --
-- Output is always initially set to "not Value", so that if the switch is
-- not found on the command line, Output still has a valid value.
-- The switch must not take any parameter.
- -- Output must exist at least as long as Config, otherwise erroneous memory
- -- access may happen.
+ --
+ -- Output must exist at least as long as Config, otherwise an erroneous
+ -- memory access may occur.
procedure Define_Switch
(Config : in out Command_Line_Configuration;
Initial : Integer := 0;
Default : Integer := 1;
Argument : String := "ARG");
- -- See Define_Switch for a description of the parameters.
- -- When the switch is found on the command line, Getopt will set
- -- Output.all to the value of the switch's parameter. If the parameter is
- -- not an integer, Invalid_Parameter is raised.
+ -- See Define_Switch for a description of the parameters. When the
+ -- switch is found on the command line, Getopt will set Output.all to the
+ -- value of the switch's parameter. If the parameter is not an integer,
+ -- Invalid_Parameter is raised.
+
-- Output is always initialized to Initial. If the switch has an optional
-- argument which isn't specified by the user, then Output will be set to
- -- Default.
- -- The switch must accept an argument.
+ -- Default. The switch must accept an argument.
procedure Define_Switch
(Config : in out Command_Line_Configuration;
Section : String := "";
Argument : String := "ARG");
-- Set Output to the value of the switch's parameter when the switch is
- -- found on the command line.
- -- Output is always initialized to the empty string if it does not have
- -- a value already (otherwise it is left as is so that you can specify the
- -- default value directly in the declaration of the variable).
- -- The switch must accept an argument.
+ -- found on the command line. Output is always initialized to the empty
+ -- string if it does not have a value already (otherwise it is left as is
+ -- so that you can specify the default value directly in the declaration
+ -- of the variable). The switch must accept an argument.
procedure Set_Usage
(Config : in out Command_Line_Configuration;
(Switch : String;
Parameter : String;
Section : String);
- -- Called when a switch is found on the command line.
- -- [Switch] includes any leading '-' that was specified in Define_Switch.
- -- This is slightly different from the functional version of Getopt above,
- -- for which Full_Switch omits the first leading '-'.
+ -- Called when a switch is found on the command line. Switch includes
+ -- any leading '-' that was specified in Define_Switch. This is slightly
+ -- different from the functional version of Getopt above, for which
+ -- Full_Switch omits the first leading '-'.
Exit_From_Command_Line : exception;
- -- Emitted when the program should exit.
- -- This is called when Getopt below has seen -h, --help or an invalid
- -- switch.
+ -- Emitted when the program should exit. This is called when Getopt below
+ -- has seen -h, --help or an invalid switch.
procedure Getopt
(Config : Command_Line_Configuration;
-- If the command line has sections (such as -bargs -cargs), then they
-- should be listed in the Sections parameter (as "-bargs -cargs").
--
- -- This function can be used to reset Cmd by passing an empty string.
+ -- This function can be used to reset Cmd by passing an empty string
--
-- If an invalid switch is found on the command line (ie wasn't defined in
-- the configuration via Define_Switch), and the configuration wasn't set
---------------
-- Iteration --
---------------
+
-- When a command line was created with the above, you can then iterate
-- over its contents using the following iterator.
-- create an Opt_Parser.
--
-- Args must be freed by the caller.
+ --
-- Expanded has the same meaning as in Start.
private
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_Uint8, -- System.Atomic_Primitives
RE_Uint16, -- System.Atomic_Primitives
RE_Uint32, -- 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_Uint8 => System_Atomic_Primitives,
RE_Uint16 => System_Atomic_Primitives,
RE_Uint32 => System_Atomic_Primitives,
-- --
------------------------------------------------------------------------------
--- ??? Need header saying what this unit is!!!
+-- 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.
package System.Atomic_Primitives is
pragma Preelaborate;
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");
end System.Atomic_Primitives;
when No_Aspect =>
raise Program_Error;
- -- Aspects taking an optional boolean argument. For all of
- -- these we just create a matching pragma and insert it, if
- -- the expression is missing or set to True. If the expression
- -- is False, we can ignore the aspect with the exception that
- -- in the case of a derived type, we must check for an illegal
- -- attempt to cancel an inherited aspect.
+ -- Aspects taking an optional boolean argument
when Boolean_Aspects =>
Set_Is_Boolean_Aspect (Aspect);
+ -- Special treatment for Aspect_Lock_Free since it is the
+ -- only Boolean_Aspect that doesn't correspond to a pragma.
+
+ if A_Id = Aspect_Lock_Free then
+ if Ekind (E) /= E_Protected_Type then
+ Error_Msg_N
+ ("aspect % only applies to protected objects",
+ Aspect);
+ end if;
+
+ -- Set the Uses_Lock_Free flag to True if there is no
+ -- expression or if the expression is True.
+
+ if No (Expr)
+ or else Is_True (Static_Boolean (Expr))
+ then
+ Set_Uses_Lock_Free (E);
+ end if;
+
+ goto Continue;
+ end if;
+
+ -- For all of these aspects we just create a matching pragma
+ -- and insert it, if the expression is missing or set to
+ -- True. If the expression is False, we can ignore the
+ -- aspect with the exception that in the case of a derived
+ -- type, we must check for an illegal attempt to cancel an
+ -- inherited aspect.
+
if Present (Expr)
and then Is_False (Static_Boolean (Expr))
then
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
+with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists;
with Freeze; use Freeze;
+with Layout; use Layout;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
-- Local Subprograms --
-----------------------
+ function Allows_Lock_Free_Implementation
+ (N : Node_Id;
+ Complain : Boolean := False) return Boolean;
+ -- This dispatch routine return True if N satisfies the following list of
+ -- lock-free restrictions for protected type declaration and protected
+ -- body:
+ --
+ -- 1) Protected type declaration
+ -- May not contain entries
+ -- Component types must support atomic compare and exchange
+ --
+ -- 2) Protected Body
+ -- Each protected subprogram body within N must satisfy:
+ -- May reference only one protected component
+ -- May not reference non-constant entities outside the protected
+ -- subprogram scope.
+ -- May not reference non-scalar out parameters
+ -- May not contain loop statements or procedure calls
+ -- Function calls and attribute references must be static
+ --
+ -- If Complain is set to True, an error message is issued when return
+ -- False.
+
procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
-- Given either a protected definition or a task definition in D, check
-- the corresponding restriction parameter identifier R, and if it is set,
-- Utility to make visible in corresponding body the entities defined in
-- task, protected type declaration, or entry declaration.
+ -------------------------------------
+ -- Allows_Lock_Free_Implementation --
+ -------------------------------------
+
+ function Allows_Lock_Free_Implementation
+ (N : Node_Id;
+ Complain : Boolean := False) return Boolean
+ is
+ begin
+ pragma Assert (Nkind_In (N,
+ N_Protected_Type_Declaration,
+ N_Protected_Body));
+
+ -- The lock-free implementation is currently enabled through a debug
+ -- flag. When Complain is True, an aspect Lock_Free forces the lock-free
+ -- implementation. In that case, the debug flag is not needed.
+
+ if not Complain
+ and then not Debug_Flag_9
+ then
+ return False;
+ end if;
+
+ -- Protected type declaration case
+
+ if Nkind (N) = N_Protected_Type_Declaration then
+ declare
+ Pdef : constant Node_Id := Protected_Definition (N);
+ Priv_Decls : constant List_Id := Private_Declarations (Pdef);
+ Vis_Decls : constant List_Id := Visible_Declarations (Pdef);
+
+ Comp_Id : Entity_Id;
+ Comp_Size : Int;
+ Comp_Type : Entity_Id;
+ Decl : Node_Id;
+
+ begin
+ -- Examine the visible declarations. Entries and entry families
+ -- are not allowed by the lock-free restrictions.
+
+ Decl := First (Vis_Decls);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Entry_Declaration then
+ if Complain then
+ Error_Msg_N ("entry not allowed for lock-free " &
+ "implementation",
+ Decl);
+ end if;
+
+ return False;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- Examine the private declarations
+
+ Decl := First (Priv_Decls);
+ while Present (Decl) loop
+
+ -- The protected type must define at least one scalar component
+
+ if Nkind (Decl) = N_Component_Declaration then
+ Comp_Id := Defining_Identifier (Decl);
+ Comp_Type := Etype (Comp_Id);
+
+ -- Make sure the protected component type has size and
+ -- alignment fields set at this point whenever this is
+ -- possible.
+
+ Layout_Type (Comp_Type);
+
+ if Known_Esize (Comp_Type) then
+ Comp_Size := UI_To_Int (Esize (Comp_Type));
+
+ -- If the Esize (Object_Size) is unknown at compile-time,
+ -- look at the RM_Size (Value_Size) since it may have been
+ -- set by an explicit representation clause.
+
+ else
+ Comp_Size := UI_To_Int (RM_Size (Comp_Type));
+ end if;
+
+ -- Check that the size of the component is 8, 16, 32 or 64
+ -- bits.
+
+ case Comp_Size is
+ when 8 | 16 | 32 | 64 =>
+ null;
+ when others =>
+ if Complain then
+ Error_Msg_N ("must support atomic operations for " &
+ "lock-free implementation",
+ Decl);
+ end if;
+
+ return False;
+ end case;
+
+ -- Entries and entry families are not allowed
+
+ elsif Nkind (Decl) = N_Entry_Declaration then
+ if Complain then
+ Error_Msg_N ("entry not allowed for lock-free " &
+ "implementation",
+ Decl);
+ end if;
+
+ return False;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end;
+
+ -- Protected body case
+
+ else
+ declare
+ Decls : constant List_Id := Declarations (N);
+ Pid : constant Entity_Id := Corresponding_Spec (N);
+ Prot_Typ_Decl : constant Node_Id := Parent (Pid);
+ Prot_Def : constant Node_Id :=
+ Protected_Definition (Prot_Typ_Decl);
+ Priv_Decls : constant List_Id :=
+ Private_Declarations (Prot_Def);
+ Decl : Node_Id;
+
+ function Satisfies_Lock_Free_Requirements
+ (Sub_Body : Node_Id) return Boolean;
+ -- Return True if protected subprogram body Sub_Body satisfies all
+ -- requirements of a lock-free implementation.
+
+ --------------------------------------
+ -- Satisfies_Lock_Free_Requirements --
+ --------------------------------------
+
+ function Satisfies_Lock_Free_Requirements
+ (Sub_Body : Node_Id) return Boolean
+ is
+ Comp : Entity_Id := Empty;
+ -- Track the current component which the body references
+
+ function Check_Node (N : Node_Id) return Traverse_Result;
+ -- Check that node N meets the lock free restrictions
+
+ ----------------
+ -- Check_Node --
+ ----------------
+
+ function Check_Node (N : Node_Id) return Traverse_Result is
+ begin
+ -- Function calls and attribute references must be static
+
+ if Nkind_In (N, N_Attribute_Reference, N_Function_Call)
+ and then not Is_Static_Expression (N)
+ then
+ return Abandon;
+
+ -- Loop statements and procedure calls are prohibited
+
+ elsif Nkind_In (N, N_Loop_Statement,
+ N_Procedure_Call_Statement)
+ then
+ return Abandon;
+
+ -- References
+
+ elsif Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ then
+ declare
+ Id : constant Entity_Id := Entity (N);
+ Sub_Id : constant Entity_Id :=
+ Corresponding_Spec (Sub_Body);
+
+ begin
+ -- Prohibit references to non-constant entities
+ -- outside the protected subprogram scope.
+
+ if Ekind (Id) in Assignable_Kind
+ and then not Scope_Within_Or_Same (Scope (Id),
+ Sub_Id)
+ and then not Scope_Within_Or_Same (Scope (Id),
+ Protected_Body_Subprogram (Sub_Id))
+ then
+ return Abandon;
+
+ -- Prohibit non-scalar out parameters (scalar
+ -- parameters are passed by copy).
+
+ elsif Ekind_In (Id, E_Out_Parameter,
+ E_In_Out_Parameter)
+ and then not Is_Scalar_Type (Etype (Id))
+ and then Scope_Within_Or_Same (Scope (Id), Sub_Id)
+ then
+ return Abandon;
+
+ -- A protected subprogram may reference only one
+ -- component of the protected type.
+
+ elsif Ekind (Id) = E_Component then
+ declare
+ Comp_Decl : constant Node_Id := Parent (Id);
+ begin
+ if Nkind (Comp_Decl) = N_Component_Declaration
+ and then Is_List_Member (Comp_Decl)
+ and then List_Containing (Comp_Decl) =
+ Priv_Decls
+ then
+ if No (Comp) then
+ Comp := Id;
+
+ -- Check if another protected component has
+ -- already been accessed by the subprogram
+ -- body.
+
+ elsif Comp /= Id then
+ return Abandon;
+ end if;
+ end if;
+ end;
+
+ elsif Ekind_In (Id, E_Constant, E_Variable)
+ and then Present (Prival_Link (Id))
+ then
+ declare
+ Comp_Decl : constant Node_Id :=
+ Parent (Prival_Link (Id));
+ begin
+ if Nkind (Comp_Decl) = N_Component_Declaration
+ and then Is_List_Member (Comp_Decl)
+ and then List_Containing (Comp_Decl) =
+ Priv_Decls
+ then
+ if No (Comp) then
+ Comp := Prival_Link (Id);
+
+ -- Check if another protected component has
+ -- already been accessed by the subprogram
+ -- body.
+
+ elsif Comp /= Prival_Link (Id) then
+ return Abandon;
+ end if;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+
+ return OK;
+ end Check_Node;
+
+ function Check_All_Nodes is new Traverse_Func (Check_Node);
+
+ -- Start of processing for Satisfies_Lock_Free_Requirements
+
+ begin
+ if Check_All_Nodes (Sub_Body) = OK then
+
+ -- Establish a relation between the subprogram body and the
+ -- unique protected component it references.
+
+ if Present (Comp) then
+ Lock_Free_Subprogram_Table.Append
+ (Lock_Free_Subprogram'(Sub_Body, Comp));
+ end if;
+
+ return True;
+ else
+ return False;
+ end if;
+ end Satisfies_Lock_Free_Requirements;
+
+ begin
+ Decl := First (Decls);
+
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Subprogram_Body
+ and then not Satisfies_Lock_Free_Requirements (Decl)
+ then
+ if Complain then
+ Error_Msg_N ("body prevents lock-free implementation",
+ Decl);
+ end if;
+
+ return False;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end;
+ end if;
+
+ return True;
+ end Allows_Lock_Free_Implementation;
+
-----------------------------
-- Analyze_Abort_Statement --
-----------------------------
procedure Analyze_Protected_Body (N : Node_Id) is
Body_Id : constant Entity_Id := Defining_Identifier (N);
+ Aspect : Node_Id;
Last_E : Entity_Id;
Spec_Id : Entity_Id;
Check_References (Spec_Id);
Process_End_Label (N, 't', Ref_Id);
End_Scope;
+
+ -- Turn on/off the lock-free implementation for the protected object
+
+ -- Look for a Lock_Free aspect with a False expression that disables the
+ -- lock-free implementation.
+
+ Aspect := First (Aspect_Specifications (Parent (Spec_Id)));
+
+ while Present (Aspect) loop
+ if Get_Aspect_Id (Chars (Identifier (Aspect))) = Aspect_Lock_Free
+ and then Present (Expression (Aspect))
+ and then Entity (Expression (Aspect)) = Standard_False
+ then
+ return;
+ end if;
+
+ Next (Aspect);
+ end loop;
+
+ -- When a Lock_Free aspect forces the lock-free implementation, verify
+ -- the protected body meets all the restrictions, otherwise
+ -- Allows_Lock_Free_Implementation issues an error message.
+
+ if Uses_Lock_Free (Spec_Id) then
+ if not Allows_Lock_Free_Implementation (N, Complain => True) then
+ return;
+ end if;
+
+ -- In other cases, check both the protected declaration and body satisfy
+ -- the lock-free restrictions.
+
+ elsif Allows_Lock_Free_Implementation (Parent (Spec_Id))
+ and then Allows_Lock_Free_Implementation (N)
+ then
+ Set_Uses_Lock_Free (Spec_Id);
+ end if;
end Analyze_Protected_Body;
----------------------------------
End_Scope;
+ -- When a Lock_Free aspect forces the lock-free implementation, check N
+ -- meets all the lock-free restrictions. Otherwise,
+ -- Allows_Lock_Free_Implementation issue an error message.
+
+ if Uses_Lock_Free (Defining_Identifier (N)) then
+ if not Allows_Lock_Free_Implementation (N, Complain => True) then
+ return;
+ end if;
+ end if;
+
-- Case of a completion of a private declaration
if T /= Def_Id
-- disastrous result.
Analyze_Protected_Type_Declaration (N);
-
- if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Id);
- end if;
end Analyze_Single_Protected_Declaration;
-------------------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- --
------------------------------------------------------------------------------
+with Table;
with Types; use Types;
package Sem_Ch9 is
procedure Analyze_Terminate_Alternative (N : Node_Id);
procedure Analyze_Timed_Entry_Call (N : Node_Id);
procedure Analyze_Triggering_Alternative (N : Node_Id);
+
+ ------------------------------
+ -- Lock Free Data Structure --
+ ------------------------------
+
+ -- A lock-free subprogram is a protected routine which references a unique
+ -- protected scalar component and does not contain statements that cause
+ -- side effects. Due to this restricted behavior, all references to shared
+ -- data from within the subprogram can be synchronized through the use of
+ -- atomic operations rather than relying on locks.
+
+ type Lock_Free_Subprogram is record
+ Sub_Body : Node_Id;
+ -- Reference to the body of a protected subprogram which meets the lock-
+ -- free requirements.
+
+ Comp_Id : Entity_Id;
+ -- Reference to the scalar component referenced from within Sub_Body
+ end record;
+
+ -- This table establishes a relation between a protected subprogram body
+ -- and a unique component it references. The table is used when building
+ -- the lock-free versions of a protected subprogram body.
+
+ package Lock_Free_Subprogram_Table is new Table.Table (
+ Table_Component_Type => Lock_Free_Subprogram,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 5,
+ Table_Increment => 5,
+ Table_Name => "Lock_Free_Subprogram_Table");
end Sem_Ch9;
Name_Dimension : constant Name_Id := N + $;
Name_Dimension_System : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
+ Name_Lock_Free : constant Name_Id := N + $;
Name_Post : constant Name_Id := N + $;
Name_Pre : constant Name_Id := N + $;
Name_Static_Predicate : constant Name_Id := N + $;
projects / platform / upstream / gcc.git / commitdiff