Skip to content

R
riscv-gcc-1
Commit 39ad1665 by Arnaud Charlet
Options

[multiple changes] 

2012-04-25  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb, csinfo.adb, lib-writ.adb, sem_ch12.adb,
	lib-xref.adb: Minor reformatting.

2012-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch9.adb: Rename Lock_Free_Sub_Type
	to Lock_Free_Subprogram. Remove type Subprogram_Id.
	Rename LF_Sub_Table to Lock_Free_Subprogram_Table.
	(Allow_Lock_Free_Implementation): Renamed to
	Allows_Lock_Free_Implementation.  Update the comment on
	lock-free restrictions. Code clean up and restructuring.
	(Build_Lock_Free_Protected_Subprogram_Body): Update the
	profile and related comments. Code clean up and restructuring.
	(Build_Lock_Free_Unprotected_Subprogram_Body): Update the
	profile and related comments. Code clean up and restructuring.
	(Comp_Of): Removed.

From-SVN: r186828
parent d024b126
Showing with 605 additions and 638 deletions
gcc/ada/ChangeLog
2012-04-25 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, csinfo.adb, lib-writ.adb, sem_ch12.adb,
lib-xref.adb: Minor reformatting.
2012-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch9.adb: Rename Lock_Free_Sub_Type
to Lock_Free_Subprogram. Remove type Subprogram_Id.
Rename LF_Sub_Table to Lock_Free_Subprogram_Table.
(Allow_Lock_Free_Implementation): Renamed to
Allows_Lock_Free_Implementation. Update the comment on
lock-free restrictions. Code clean up and restructuring.
(Build_Lock_Free_Protected_Subprogram_Body): Update the
profile and related comments. Code clean up and restructuring.
(Build_Lock_Free_Unprotected_Subprogram_Body): Update the
profile and related comments. Code clean up and restructuring.
(Comp_Of): Removed.
2012-04-25 Vincent Celier <celier@adacore.com> 2012-04-25 Vincent Celier <celier@adacore.com>
* sem_ch12.adb (Inherit_Context): Compare library units, not * sem_ch12.adb (Inherit_Context): Compare library units, not
......
gcc/ada/csinfo.adb
...@@ -199,36 +199,36 @@ begin ...@@ -199,36 +199,36 @@ begin
-- by Csinfo, since they are specially handled. This means that any field -- by Csinfo, since they are specially handled. This means that any field
-- definition or subprogram with a matching name is ignored. -- definition or subprogram with a matching name is ignored.
Set (Special, "Analyzed", True); Set (Special, "Analyzed", True);
Set (Special, "Assignment_OK", True); Set (Special, "Assignment_OK", True);
Set (Special, "Associated_Node", True); Set (Special, "Associated_Node", True);
Set (Special, "Cannot_Be_Constant", True); Set (Special, "Cannot_Be_Constant", True);
Set (Special, "Chars", True); Set (Special, "Chars", True);
Set (Special, "Comes_From_Source", True); Set (Special, "Comes_From_Source", True);
Set (Special, "Do_Overflow_Check", True); Set (Special, "Do_Overflow_Check", True);
Set (Special, "Do_Range_Check", True); Set (Special, "Do_Range_Check", True);
Set (Special, "Entity", True); Set (Special, "Entity", True);
Set (Special, "Entity_Or_Associated_Node", True); Set (Special, "Entity_Or_Associated_Node", True);
Set (Special, "Error_Posted", True); Set (Special, "Error_Posted", True);
Set (Special, "Etype", True); Set (Special, "Etype", True);
Set (Special, "Evaluate_Once", True); Set (Special, "Evaluate_Once", True);
Set (Special, "First_Itype", True); Set (Special, "First_Itype", True);
Set (Special, "Has_Aspect_Specifications", True); Set (Special, "Has_Aspect_Specifications", True);
Set (Special, "Has_Dynamic_Itype", True); Set (Special, "Has_Dynamic_Itype", True);
Set (Special, "Has_Dynamic_Range_Check", True); Set (Special, "Has_Dynamic_Range_Check", True);
Set (Special, "Has_Dynamic_Length_Check", True); Set (Special, "Has_Dynamic_Length_Check", True);
Set (Special, "Has_Private_View", True); Set (Special, "Has_Private_View", True);
Set (Special, "Implicit_With_From_Instantiation", True); Set (Special, "Implicit_With_From_Instantiation", True);
Set (Special, "Is_Controlling_Actual", True); Set (Special, "Is_Controlling_Actual", True);
Set (Special, "Is_Overloaded", True); Set (Special, "Is_Overloaded", True);
Set (Special, "Is_Static_Expression", True); Set (Special, "Is_Static_Expression", True);
Set (Special, "Left_Opnd", True); Set (Special, "Left_Opnd", True);
Set (Special, "Must_Not_Freeze", True); Set (Special, "Must_Not_Freeze", True);
Set (Special, "Nkind_In", True); Set (Special, "Nkind_In", True);
Set (Special, "Parens", True); Set (Special, "Parens", True);
Set (Special, "Pragma_Name", True); Set (Special, "Pragma_Name", True);
Set (Special, "Raises_Constraint_Error", True); Set (Special, "Raises_Constraint_Error", True);
Set (Special, "Right_Opnd", True); Set (Special, "Right_Opnd", True);
-- Loop to acquire information from node definitions in sinfo.ads, -- Loop to acquire information from node definitions in sinfo.ads,
-- checking for consistency in Op/Flag assignments to each synonym -- checking for consistency in Op/Flag assignments to each synonym
...@@ -627,7 +627,6 @@ begin ...@@ -627,7 +627,6 @@ begin
declare declare
List : constant TV.Table_Array := Convert_To_Array (Fields1); List : constant TV.Table_Array := Convert_To_Array (Fields1);
begin begin
if List'Length /= 0 then if List'Length /= 0 then
Put_Line ("Missing procedure Set_" & List (1).Name & " in body"); Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
......
gcc/ada/exp_ch9.adb
...@@ -81,29 +81,24 @@ package body Exp_Ch9 is ...@@ -81,29 +81,24 @@ package body Exp_Ch9 is
-- Lock Free Data Structure -- -- Lock Free Data Structure --
------------------------------ ------------------------------
-- A data structure used for the Lock Free (LF) implementation of protected type Lock_Free_Subprogram is record
-- objects. Since a protected subprogram can only access a single protected
-- component in the LF implementation, this structure stores each protected
-- subprogram and its accessed protected component when the protected
-- object allows the LF implementation.
type Lock_Free_Sub_Type is record
Sub_Body : Node_Id; Sub_Body : Node_Id;
Comp_Id : Entity_Id; Comp_Id : Entity_Id;
end record; end record;
-- This data structure and its fields must be documented, ALL global
-- data structures must be documented. We never rely on guessing what
-- things mean from their names.
subtype Subprogram_Id is Nat; -- The following table establishes a relation between a subprogram body and
-- an unique protected component referenced in this body.
-- The following table used for the Lock Free implementation of protected
-- objects maps Lock_Free_Sub_Type to Subprogram_Id.
package LF_Sub_Table is new Table.Table ( package Lock_Free_Subprogram_Table is new Table.Table (
Table_Component_Type => Lock_Free_Sub_Type, Table_Component_Type => Lock_Free_Subprogram,
Table_Index_Type => Subprogram_Id, Table_Index_Type => Nat,
Table_Low_Bound => 1, Table_Low_Bound => 1,
Table_Initial => 5, Table_Initial => 5,
Table_Increment => 5, Table_Increment => 5,
Table_Name => "LF_Sub_Table"); Table_Name => "Lock_Free_Subprogram_Table");
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
...@@ -139,9 +134,19 @@ package body Exp_Ch9 is ...@@ -139,9 +134,19 @@ package body Exp_Ch9 is
-- Decls is the list of declarations to be enhanced. -- Decls is the list of declarations to be enhanced.
-- Ent is the entity for the original entry body. -- Ent is the entity for the original entry body.
function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean; function Allows_Lock_Free_Implementation (N : Node_Id) return Boolean;
-- Given a protected body N, return True if N permits a lock free -- Given a protected body N, return True if N satisfies the following list
-- implementation. -- 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; function Build_Accept_Body (Astat : Node_Id) return Node_Id;
-- Transform accept statement into a block with added exception handler. -- Transform accept statement into a block with added exception handler.
...@@ -189,20 +194,20 @@ package body Exp_Ch9 is ...@@ -189,20 +194,20 @@ package body Exp_Ch9 is
-- Build subprogram declaration for previous one -- Build subprogram declaration for previous one
function Build_Lock_Free_Protected_Subprogram_Body function Build_Lock_Free_Protected_Subprogram_Body
(N : Node_Id; (N : Node_Id;
Pid : Node_Id; Prot_Typ : Node_Id;
N_Op_Spec : Node_Id) return Node_Id; Unprot_Spec : Node_Id) return Node_Id;
-- This function is used to construct the lock free version of a protected -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
-- subprogram when the protected type denoted by Pid allows the lock free -- the subprogram specification of the unprotected version of N. Transform
-- implementation. It only contains a call to the unprotected version of -- N such that it invokes the unprotected version of the body.
-- the subprogram body.
function Build_Lock_Free_Unprotected_Subprogram_Body function Build_Lock_Free_Unprotected_Subprogram_Body
(N : Node_Id; (N : Node_Id;
Pid : Node_Id) return Node_Id; Prot_Typ : Node_Id) return Node_Id;
-- This function is used to construct the lock free version of an -- N denotes a subprogram body of protected type Prot_Typ. Build a version
-- unprotected subprogram when the protected type denoted by Pid allows the -- of N where the original statements of N are synchronized through atomic
-- lock free implementation. -- actions such as compare and exchange. Prior to invoking this routine, it
-- has been established that N can be implemented in a lock-free fashion.
function Build_Parameter_Block function Build_Parameter_Block
(Loc : Source_Ptr; (Loc : Source_Ptr;
...@@ -349,10 +354,6 @@ package body Exp_Ch9 is ...@@ -349,10 +354,6 @@ package body Exp_Ch9 is
-- For each entry family in a concurrent type, create an anonymous array -- For each entry family in a concurrent type, create an anonymous array
-- type of the right size, and add a component to the corresponding_record. -- type of the right size, and add a component to the corresponding_record.
function Comp_Of (Sub_Body : Node_Id) return Entity_Id;
-- For the lock free implementation, return the protected component entity
-- referenced in Sub_Body using LF_Sub_Table.
function Concurrent_Object function Concurrent_Object
(Spec_Id : Entity_Id; (Spec_Id : Entity_Id;
Conc_Typ : Entity_Id) return Entity_Id; Conc_Typ : Entity_Id) return Entity_Id;
...@@ -819,221 +820,180 @@ package body Exp_Ch9 is ...@@ -819,221 +820,180 @@ package body Exp_Ch9 is
Prepend_To (Decls, Decl); Prepend_To (Decls, Decl);
end Add_Object_Pointer; end Add_Object_Pointer;
------------------------------------ -------------------------------------
-- Allow_Lock_Free_Implementation -- -- Allows_Lock_Free_Implementation --
------------------------------------ -------------------------------------
-- Here are the restrictions for the Lock Free implementation
-- Implementation Restrictions on protected declaration
-- There must be only protected scalar components (at least one)
-- Component types must support an atomic compare_exchange primitive
-- (size equals to 1, 2, 4 or 8 bytes).
-- No entries
-- Implementation Restrictions on protected operations
-- Cannot refer to non-constant outside of the scope of the protected
-- operation.
-- Can only access a single protected component: all protected
-- component names appearing in a scope (including nested scopes)
-- must statically denote the same protected component.
-- Fundamental Restrictions on protected operations
-- No loop and procedure call statements
-- Any function call and attribute reference must be static
function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean is
Decls : constant List_Id := Declarations (N);
Spec : constant Entity_Id := Corresponding_Spec (N);
Pro_Def : constant Node_Id := Protected_Definition (Parent (Spec));
Pri_Decls : constant List_Id := Private_Declarations (Pro_Def);
Vis_Decls : constant List_Id := Visible_Declarations (Pro_Def);
Comp_Id : Entity_Id;
Comp_Size : Int;
Comp_Type : Entity_Id;
No_Component : Boolean := True;
N_Decl : Node_Id;
function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean;
-- Return True if the protected subprogram body Sub_Body doesn't
-- prevent the lock free code expansion, i.e. Sub_Body meets all the
-- restrictions listed below that allow the lock free implementation.
--
-- Can only access a single protected component
--
-- No loop and procedure call statements
-- Any function call and attribute reference must be static 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);
-- Cannot refer to non-constant outside of the scope of the protected function Satisfies_Lock_Free_Requirements
-- subprogram. (Sub_Body : Node_Id) return Boolean;
-- Return True if protected subprogram body Sub_Body satisfies all
-- requirements of a lock-free implementation.
---------------------- --------------------------------------
-- Permit_Lock_Free -- -- Satisfies_Lock_Free_Requirements --
---------------------- --------------------------------------
function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean is function Satisfies_Lock_Free_Requirements
Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body); (Sub_Body : Node_Id) return Boolean
Comp_Id : Entity_Id := Empty; is
LF_Sub : Lock_Free_Sub_Type; Comp : Entity_Id := Empty;
-- Track the current component which the body references
function Check_Node (N : Node_Id) return Traverse_Result; function Check_Node (N : Node_Id) return Traverse_Result;
-- Check the node N meet the lock free restrictions -- Check that node N meets the lock free restrictions
function Check_All_Nodes is new Traverse_Func (Check_Node);
---------------- ----------------
-- Check_Node -- -- Check_Node --
---------------- ----------------
function Check_Node (N : Node_Id) return Traverse_Result is function Check_Node (N : Node_Id) return Traverse_Result is
Comp_Decl : Node_Id;
Id : Entity_Id;
begin begin
case Nkind (N) is -- Function calls and attribute references must be static
-- ??? what about side-effects
-- Function call or attribute reference case
when N_Function_Call | N_Attribute_Reference => if Nkind_In (N, N_Attribute_Reference, N_Function_Call)
and then not Is_Static_Expression (N)
-- Any function call and attribute reference must be static then
return Abandon;
if not Is_Static_Expression (N) then
return Abandon;
end if;
-- Loop and procedure call statement case
when N_Procedure_Call_Statement | N_Loop_Statement => -- Loop statements and procedure calls are prohibited
-- No loop and procedure call statements
return Abandon;
-- Identifier case elsif Nkind_In (N, N_Loop_Statement,
N_Procedure_Call_Statement)
then
return Abandon;
when N_Identifier => -- References
if Present (Entity (N)) then
Id := Entity (N);
-- Cannot refer to non-constant entities outside of the elsif Nkind (N) = N_Identifier
-- scope of the protected subprogram. and then Present (Entity (N))
then
declare
Id : constant Entity_Id := Entity (N);
Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body);
if Ekind (Id) in Assignable_Kind begin
and then Sloc (Scope (Id)) > No_Location -- Prohibit references to non-constant entities outside the
and then not Scope_Within_Or_Same (Scope (Id), Sub_Id) -- protected subprogram scope.
and then not Scope_Within_Or_Same (Scope (Id),
Protected_Body_Subprogram (Sub_Id))
then
return Abandon;
end if;
-- Can only access a single protected component 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;
if Ekind_In (Id, E_Constant, E_Variable) -- A protected subprogram may reference only one component
and then Present (Prival_Link (Id)) -- of the protected type.
then
Comp_Decl := Parent (Prival_Link (Id));
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 if Nkind (Comp_Decl) = N_Component_Declaration
and then Is_List_Member (Comp_Decl) and then Is_List_Member (Comp_Decl)
and then List_Containing (Comp_Decl) = Pri_Decls and then List_Containing (Comp_Decl) = Priv_Decls
then then
if No (Comp) then
Comp := Prival_Link (Id);
-- Check if another protected component has already -- Check if another protected component has already
-- been accessed by the subprogram body. -- been accessed by the subprogram body.
if Present (Comp_Id) elsif Comp /= Prival_Link (Id) then
and then Comp_Id /= Prival_Link (Id)
then
return Abandon; return Abandon;
elsif not Present (Comp_Id) then
Comp_Id := Prival_Link (Id);
end if; end if;
end if; end if;
end if; end;
end if; end if;
end;
-- Ok for all other nodes end if;
when others => return OK;
end case;
return OK; return OK;
end Check_Node; end Check_Node;
-- Start of processing for Permit_Lock_Free function Check_All_Nodes is new Traverse_Func (Check_Node);
-- Start of processing for Satisfies_Lock_Free_Requirements
begin begin
if Check_All_Nodes (Sub_Body) = OK then if Check_All_Nodes (Sub_Body) = OK then
-- Fill LF_Sub with Sub_Body and its corresponding protected -- Establish a relation between the subprogram body and the unique
-- component entity and then store LF_Sub in the lock free -- protected component it references.
-- subprogram table LF_Sub_Table.
LF_Sub.Sub_Body := Sub_Body; if Present (Comp) then
LF_Sub.Comp_Id := Comp_Id; Lock_Free_Subprogram_Table.Append
LF_Sub_Table.Append (LF_Sub); (Lock_Free_Subprogram'(Sub_Body, Comp));
return True; end if;
return True;
else else
return False; return False;
end if; end if;
end Permit_Lock_Free; 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 Allow_Lock_Free_Implementation -- Start of processing for Allows_Lock_Free_Implementation
begin begin
-- Debug switch -gnatd9 enables Lock Free implementation -- The lock-free implementation is currently enabled through a debug
-- flag.
if not Debug_Flag_9 then if not Debug_Flag_9 then
return False; return False;
end if; end if;
-- Look for any entries declared in the visible part of the protected -- Examine the visible declarations. Entries and entry families are not
-- declaration. -- allowed by the lock-free restrictions.
N_Decl := First (Vis_Decls); Decl := First (Vis_Decls);
while Present (N_Decl) loop while Present (Decl) loop
if Nkind (N_Decl) = N_Entry_Declaration then if Nkind (Decl) = N_Entry_Declaration then
return False; return False;
end if; end if;
N_Decl := Next (N_Decl); Next (Decl);
end loop; end loop;
-- Look for any entry, plus look for any scalar component declared in -- Examine the private declarations
-- the private part of the protected declaration.
N_Decl := First (Pri_Decls); Decl := First (Priv_Decls);
while Present (N_Decl) loop while Present (Decl) loop
-- Check at least one scalar component is declared -- The protected type must define at least one scalar component
if Nkind (N_Decl) = N_Component_Declaration then if Nkind (Decl) = N_Component_Declaration then
if No_Component then Has_Component := True;
No_Component := False;
end if;
Comp_Id := Defining_Identifier (N_Decl); Comp_Id := Defining_Identifier (Decl);
Comp_Type := Etype (Comp_Id); Comp_Type := Etype (Comp_Id);
-- Verify the component is a scalar
if not Is_Scalar_Type (Comp_Type) then if not Is_Scalar_Type (Comp_Type) then
return False; return False;
end if; end if;
Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type))); Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type)));
-- Check the size of the component is 8, 16, 32 or 64 bits -- Check that the size of the component is 8, 16, 32 or 64 bits
case Comp_Size is case Comp_Size is
when 8 | 16 | 32 | 64 => when 8 | 16 | 32 | 64 =>
...@@ -1042,39 +1002,37 @@ package body Exp_Ch9 is ...@@ -1042,39 +1002,37 @@ package body Exp_Ch9 is
return False; return False;
end case; end case;
-- Check there is no entry declared in the private part. -- Entries and entry families are not allowed
else elsif Nkind (Decl) = N_Entry_Declaration then
if Nkind (N_Decl) = N_Entry_Declaration then return False;
return False;
end if;
end if; end if;
N_Decl := Next (N_Decl); Next (Decl);
end loop; end loop;
-- One scalar component must be present -- At least one scalar component must be present
if No_Component then if not Has_Component then
return False; return False;
end if; end if;
-- Ensure all protected subprograms meet the restrictions that allow the -- Ensure that all protected subprograms meet the restrictions of the
-- lock free implementation. -- lock-free implementation.
N_Decl := First (Decls); Decl := First (Decls);
while Present (N_Decl) loop while Present (Decl) loop
if Nkind (N_Decl) = N_Subprogram_Body if Nkind (Decl) = N_Subprogram_Body
and then not Permit_Lock_Free (N_Decl) and then not Satisfies_Lock_Free_Requirements (Decl)
then then
return False; return False;
end if; end if;
Next (N_Decl); Next (Decl);
end loop; end loop;
return True; return True;
end Allow_Lock_Free_Implementation; end Allows_Lock_Free_Implementation;
----------------------- -----------------------
-- Build_Accept_Body -- -- Build_Accept_Body --
...@@ -3189,293 +3147,271 @@ package body Exp_Ch9 is ...@@ -3189,293 +3147,271 @@ package body Exp_Ch9 is
----------------------------------------------- -----------------------------------------------
function Build_Lock_Free_Protected_Subprogram_Body function Build_Lock_Free_Protected_Subprogram_Body
(N : Node_Id; (N : Node_Id;
Pid : Node_Id; Prot_Typ : Node_Id;
N_Op_Spec : Node_Id) return Node_Id Unprot_Spec : Node_Id) return Node_Id
is is
Loc : constant Source_Ptr := Sloc (N); Actuals : constant List_Id := New_List;
Op_Spec : Node_Id; Loc : constant Source_Ptr := Sloc (N);
P_Op_Spec : Node_Id; Spec : constant Node_Id := Specification (N);
Uactuals : List_Id; Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec);
Pformal : Node_Id; Formal : Node_Id;
Unprot_Call : Node_Id; Prot_Spec : Node_Id;
R : Node_Id; Stmt : Node_Id;
Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
Exc_Safe : Boolean;
begin begin
Op_Spec := Specification (N); -- Create the protected version of the body
Exc_Safe := Is_Exception_Safe (N);
P_Op_Spec := Prot_Spec :=
Build_Protected_Sub_Specification (N, Pid, Protected_Mode); Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode);
-- Build a list of the formal parameters of the protected version of -- Build the actual parameters which appear in the call to the
-- the subprogram to use as the actual parameters of the unprotected -- unprotected version of the body.
-- version.
Uactuals := New_List; Formal := First (Parameter_Specifications (Prot_Spec));
Pformal := First (Parameter_Specifications (P_Op_Spec)); while Present (Formal) loop
while Present (Pformal) loop Append_To (Actuals,
Append_To (Uactuals, Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
Next (Pformal);
end loop;
-- Make a call to the unprotected version of the subprogram built above Next (Formal);
-- for use by the protected version built below. end loop;
if Nkind (Op_Spec) = N_Function_Specification then -- Function case, generate:
if Exc_Safe then -- return <Unprot_Func_Call>;
R := Make_Temporary (Loc, 'R');
Unprot_Call :=
Make_Object_Declaration (Loc,
Defining_Identifier => R,
Constant_Present => True,
Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
Return_Stmt := if Nkind (Spec) = N_Function_Specification then
Make_Simple_Return_Statement (Loc, Stmt :=
Expression => New_Reference_To (R, Loc)); Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc, Chars (Unprot_Id)),
Parameter_Associations => Actuals));
else -- Procedure case, call the unprotected version
Unprot_Call := Make_Simple_Return_Statement (Loc,
Expression => Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
end if;
else else
Unprot_Call := Stmt :=
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name =>
Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), Make_Identifier (Loc, Chars (Unprot_Id)),
Parameter_Associations => Uactuals); Parameter_Associations => Actuals);
end if;
if Nkind (Op_Spec) = N_Function_Specification
and then Exc_Safe
then
Unprot_Call :=
Make_Block_Statement (Loc,
Declarations => New_List (Unprot_Call),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Return_Stmt)));
end if; end if;
return return
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Declarations => Empty_List, Declarations => Empty_List,
Specification => P_Op_Spec, Specification => Prot_Spec,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Unprot_Call))); Statements => New_List (Stmt)));
end Build_Lock_Free_Protected_Subprogram_Body; end Build_Lock_Free_Protected_Subprogram_Body;
------------------------------------------------- -------------------------------------------------
-- Build_Lock_Free_Unprotected_Subprogram_Body -- -- Build_Lock_Free_Unprotected_Subprogram_Body --
------------------------------------------------- -------------------------------------------------
-- Procedures which meet the lock-free implementation requirements and
-- reference a unique scalar component Comp are expanded in the following
-- manner:
-- procedure P (...) is
-- <original declarations>
-- begin
-- loop
-- declare
-- Saved_Comp : constant ... := Atomic_Load (Comp'Address);
-- Current_Comp : ... := Saved_Comp;
-- begin
-- <original statements>
-- exit when Atomic_Compare (Comp, Saved_Comp, Current_Comp);
-- end;
-- <<L0>>
-- end loop;
-- end P;
-- References to Comp which appear in the original statements are replaced
-- with references to Current_Comp. Each return and raise statement of P is
-- transformed into an atomic status check:
-- if Atomic_Compare (Comp, Saved_Comp, Current_Comp) then
-- <original statement>
-- else
-- goto L0;
-- end if;
-- Functions which meet the lock-free implementation requirements and
-- reference a unique scalar component Comp are expanded in the following
-- manner:
-- function F (...) return ... is
-- <original declarations>
-- Saved_Comp : constant ... := Atomic_Load (Comp'Address);
-- begin
-- <original statements>
-- end F;
-- References to Comp which appear in the original statements are replaced
-- with references to Saved_Comp.
function Build_Lock_Free_Unprotected_Subprogram_Body function Build_Lock_Free_Unprotected_Subprogram_Body
(N : Node_Id; (N : Node_Id;
Pid : Node_Id) return Node_Id Prot_Typ : Node_Id) return Node_Id
is is
Decls : constant List_Id := Declarations (N); Is_Procedure : constant Boolean :=
Is_Procedure : constant Boolean :=
Ekind (Corresponding_Spec (N)) = E_Procedure; Ekind (Corresponding_Spec (N)) = E_Procedure;
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Label_Id : Entity_Id := Empty;
procedure Process_Stmts
(Stmts : List_Id;
Compare : Entity_Id;
Unsigned : Entity_Id;
Comp : Entity_Id;
Saved_Comp : Entity_Id;
Current_Comp : Entity_Id);
-- 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))
-- then
-- <Stmt>;
-- else
-- goto L0;
-- end if;
--
-- Replace all references to Comp with a reference to Current_Comp.
function Ren_Comp_Id (Decls : List_Id) return Entity_Id; function Referenced_Component (N : Node_Id) return Entity_Id;
-- Given the list of delaration Decls, return the renamed entity -- Subprograms which meet the lock-free implementation criteria are
-- of the protected component accessed by the subprogram body. -- allowed to reference only one unique component. Return the prival
-- of the said component.
----------------- -------------------
-- Ren_Comp_Id -- -- Process_Stmts --
----------------- -------------------
function Ren_Comp_Id (Decls : List_Id) return Entity_Id is procedure Process_Stmts
N_Decl : Node_Id; (Stmts : List_Id;
Pri_Link : Node_Id; Compare : Entity_Id;
Unsigned : Entity_Id;
Comp : Entity_Id;
Saved_Comp : Entity_Id;
Current_Comp : Entity_Id)
is
function Process_Node (N : Node_Id) return Traverse_Result;
-- Transform a single node if it is a return statement, a raise
-- statement or a reference to Comp.
begin ------------------
N_Decl := First (Decls); -- Process_Node --
while Present (N_Decl) loop ------------------
-- Look for a renaming declaration function Process_Node (N : Node_Id) return Traverse_Result is
if Nkind (N_Decl) = N_Object_Renaming_Declaration then procedure Wrap_Statement (Stmt : Node_Id);
Pri_Link := Prival_Link (Defining_Identifier (N_Decl)); -- Wrap an arbitrary statement inside an if statement where the
-- condition does an atomic check on the state of the object.
-- Compare the renamed entity and the accessed component entity --------------------
-- in the LF_Sub_Table. -- Wrap_Statement --
--------------------
if Present (Pri_Link) and then Pri_Link = Comp_Of (N) then procedure Wrap_Statement (Stmt : Node_Id) is
return Defining_Identifier (N_Decl); begin
-- The first time through, create the declaration of a label
-- which is used to skip the remainder of source statements if
-- the state of the object has changed.
if No (Label_Id) then
Label_Id :=
Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id)));
end if; end if;
end if;
Next (N_Decl);
end loop;
return Empty;
end Ren_Comp_Id;
Obj_Id : constant Entity_Id := Ren_Comp_Id (Decls);
At_Comp_Id : Entity_Id;
At_Load_Id : Entity_Id;
Copy_Id : Entity_Id;
Exit_Stmt : Node_Id;
Label : Node_Id := Empty;
Label_Id : Entity_Id;
New_Body : Node_Id;
New_Decls : List_Id;
New_Stmts : List_Id;
Obj_Typ : Entity_Id;
Old_Id : Entity_Id;
Typ_Size : Int;
Unsigned_Id : Entity_Id;
function Make_If (Stmt : Node_Id) return Node_Id;
-- Given the statement Stmt, return an if statement with Stmt at the end
-- of the list of statements.
procedure Process_Stmts (Stmts : List_Id);
-- Wrap each return and raise statements in Stmts into an if statement
-- generated by Make_If. Replace all references to the protected object
-- Obj by a reference to its copy Obj_Copy.
-------------
-- Make_If --
-------------
function Make_If (Stmt : Node_Id) return Node_Id is
begin
-- Generate (for Typ_Size = 32):
-- if System.Atomic_Primitives.Atomic_Compare_Exchange_32
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
-- then
-- < Stmt >
-- else
-- goto L0;
-- end if;
-- Check whether a label has already been created
if not Present (Label) then
-- Create a label which will point just after the last
-- statement of the loop statement generated in step 3.
-- Generate:
-- L0 : Label;
Label_Id :=
Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id)));
Label := Make_Label (Loc, Label_Id);
Append_To (Decls,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Label_Id),
Label_Construct => Label));
end if;
return
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name => New_Reference_To (At_Comp_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Old_Id, Loc)),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Copy_Id, Loc)))),
Then_Statements => New_List ( -- Generate:
Relocate_Node (Stmt)),
Else_Statements => New_List ( -- if System.Atomic_Primitives.Atomic_Compare_Exchange
Make_Goto_Statement (Loc, -- (Comp'Address,
Name => New_Reference_To (Entity (Label_Id), Loc)))); -- Interfaces.Unsigned (Saved_Comp),
end Make_If; -- Interfaces.Unsigned (Current_Comp))
-- then
-- <Stmt>;
-- else
-- goto L0;
-- end if;
Rewrite (Stmt,
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (Compare, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Comp, Loc),
Attribute_Name => Name_Address),
------------------- Unchecked_Convert_To (Unsigned,
-- Process_Stmts -- New_Reference_To (Saved_Comp, Loc)),
-------------------
procedure Process_Stmts (Stmts : List_Id) is Unchecked_Convert_To (Unsigned,
Stmt : Node_Id; New_Reference_To (Current_Comp, Loc)))),
function Check_Node (N : Node_Id) return Traverse_Result; Then_Statements => New_List (Relocate_Node (Stmt)),
-- Recognize a return and raise statement and wrap it into an if
-- statement. Replace all references to the protected object by
-- a reference to its copy. Reset all Analyzed flags in order to
-- reanalyze statments inside the new unprotected subprogram body.
procedure Process_Nodes is Else_Statements => New_List (
new Traverse_Proc (Check_Node); Make_Goto_Statement (Loc,
Name => New_Reference_To (Entity (Label_Id), Loc)))));
end Wrap_Statement;
---------------- -- Start of processing for Process_Node
-- Check_Node --
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
begin begin
-- In case of a procedure, wrap each return and raise statements -- Wrap each return and raise statement that appear inside a
-- inside an if statement created by Make_If. -- procedure. Skip the last return statement which is added by
-- default since it is transformed into an exit statement.
if Is_Procedure if Is_Procedure
and then Nkind_In (N, N_Simple_Return_Statement, and then Nkind_In (N, N_Simple_Return_Statement,
N_Extended_Return_Statement, N_Extended_Return_Statement,
N_Raise_Statement) N_Raise_Statement)
and then and then Nkind (Last (Stmts)) /= N_Simple_Return_Statement
(Nkind (N) /= N_Simple_Return_Statement
or else N /= Last (Stmts))
then then
Rewrite (N, Make_If (N)); Wrap_Statement (N);
return Skip; return Skip;
-- Replace all references to the protected object by a reference -- Replace all references to the original component by a reference
-- to the new copy. -- to the current state of the component.
elsif Nkind (N) = N_Identifier elsif Nkind (N) = N_Identifier
and then Present (Entity (N)) and then Present (Entity (N))
and then Entity (N) = Obj_Id and then Entity (N) = Comp
then then
Rewrite (N, Make_Identifier (Loc, Chars (Copy_Id))); Rewrite (N, Make_Identifier (Loc, Chars (Current_Comp)));
return Skip; return Skip;
end if; end if;
-- We mark the node as unanalyzed in order to reanalyze it inside -- Force reanalysis
-- the unprotected subprogram body.
Set_Analyzed (N, False); Set_Analyzed (N, False);
return OK; return OK;
end Check_Node; end Process_Node;
procedure Process_Nodes is new Traverse_Proc (Process_Node);
-- Local variables
Stmt : Node_Id;
-- Start of processing for Process_Stmts -- Start of processing for Process_Stmts
begin begin
-- Process_Nodes for each statement in Stmts
Stmt := First (Stmts); Stmt := First (Stmts);
while Present (Stmt) loop while Present (Stmt) loop
Process_Nodes (Stmt); Process_Nodes (Stmt);
...@@ -3483,210 +3419,237 @@ package body Exp_Ch9 is ...@@ -3483,210 +3419,237 @@ package body Exp_Ch9 is
end loop; end loop;
end Process_Stmts; end Process_Stmts;
--------------------------
-- Referenced_Component --
--------------------------
function Referenced_Component (N : Node_Id) return Entity_Id is
Comp : Entity_Id;
Decl : Node_Id;
Source_Comp : Entity_Id := Empty;
begin
-- Find the unique source component which N references in its
-- statements.
for Index in 1 .. Lock_Free_Subprogram_Table.Last loop
declare
Element : Lock_Free_Subprogram renames
Lock_Free_Subprogram_Table.Table (Index);
begin
if Element.Sub_Body = N then
Source_Comp := Element.Comp_Id;
exit;
end if;
end;
end loop;
if No (Source_Comp) then
return Empty;
end if;
-- Find the prival which corresponds to the source component within
-- the declarations of N.
Decl := First (Declarations (N));
while Present (Decl) loop
-- Privals appear as object renamings
if Nkind (Decl) = N_Object_Renaming_Declaration then
Comp := Defining_Identifier (Decl);
if Present (Prival_Link (Comp))
and then Prival_Link (Comp) = Source_Comp
then
return Comp;
end if;
end if;
Next (Decl);
end loop;
return Empty;
end Referenced_Component;
-- Local variables
Comp : constant Entity_Id := Referenced_Component (N);
Decls : constant List_Id := Declarations (N);
Stmts : List_Id;
-- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
begin begin
New_Stmts := New_Copy_List (Statements (Handled_Statement_Sequence (N))); Stmts := New_Copy_List (Statements (Handled_Statement_Sequence (N)));
-- Do the transformation only if the subprogram accesses a protected -- Perform the lock-free expansion when the subprogram references a
-- component. -- protected component.
if not Present (Obj_Id) then if Present (Comp) then
goto Continue; declare
end if; Comp_Typ : constant Entity_Id := Etype (Comp);
Typ_Size : constant Int := UI_To_Int (Esize (Comp_Typ));
Copy_Id := Block_Decls : List_Id;
Make_Defining_Identifier (Loc, Compare : Entity_Id;
Chars => New_External_Name (Chars (Obj_Id), Suffix => "_copy")); Current_Comp : Entity_Id;
Decl : Node_Id;
Label : Node_Id;
Load : Entity_Id;
Saved_Comp : Entity_Id;
Stmt : Node_Id;
Unsigned : Entity_Id;
Obj_Typ := Etype (Obj_Id); begin
Typ_Size := UI_To_Int (Esize (Base_Type (Obj_Typ))); -- Retrieve all relevant atomic routines and types
Process_Stmts (New_Stmts); case Typ_Size is
when 8 =>
Compare := RTE (RE_Atomic_Compare_Exchange_8);
Load := RTE (RE_Atomic_Load_8);
Unsigned := RTE (RE_Uint8);
-- Procedure case when 16 =>
Compare := RTE (RE_Atomic_Compare_Exchange_16);
Load := RTE (RE_Atomic_Load_16);
Unsigned := RTE (RE_Uint16);
if Is_Procedure then when 32 =>
case Typ_Size is Compare := RTE (RE_Atomic_Compare_Exchange_32);
when 8 => Load := RTE (RE_Atomic_Load_32);
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_8); Unsigned := RTE (RE_Uint32);
At_Load_Id := RTE (RE_Atomic_Load_8);
Unsigned_Id := RTE (RE_Uint8);
when 16 => when 64 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_16); Compare := RTE (RE_Atomic_Compare_Exchange_64);
At_Load_Id := RTE (RE_Atomic_Load_16); Load := RTE (RE_Atomic_Load_64);
Unsigned_Id := RTE (RE_Uint16); Unsigned := RTE (RE_Uint64);
when 32 => when others =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_32); raise Program_Error;
At_Load_Id := RTE (RE_Atomic_Load_32); end case;
Unsigned_Id := RTE (RE_Uint32);
when 64 => -- Generate:
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_64); -- Saved_Comp : constant Comp_Typ :=
At_Load_Id := RTE (RE_Atomic_Load_64); -- Comp_Typ (Atomic_Load (Comp'Address));
Unsigned_Id := RTE (RE_Uint64);
when others => null;
end case;
-- Generate (e.g. for Typ_Size = 32): Saved_Comp :=
Make_Defining_Identifier (Loc,
-- begin New_External_Name (Chars (Comp), Suffix => "_saved"));
-- loop
-- declare
-- Obj_Old : constant Obj_Typ :=
-- Obj_Typ!
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
-- Obj_Copy : Obj_Typ := Obj_Old;
-- begin
-- < New_Stmts >
-- exit when
-- System.Atomic_Primitives.Atomic_Compare_Exchange_32
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
-- end;
-- end loop;
-- end;
-- Step 1: Define a copy and save the old value of the protected
-- object. The copy replaces all the references to the object present
-- in the body of the procedure.
-- Generate: Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Saved_Comp,
Constant_Present => True,
Object_Definition => New_Reference_To (Comp_Typ, Loc),
Expression =>
Unchecked_Convert_To (Comp_Typ,
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)))));
-- Obj_Old : constant Obj_Typ := -- Protected procedures
-- Obj_Typ!
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
-- Obj_Copy : Obj_Typ := Obj_Old;
Old_Id := Make_Defining_Identifier (Loc, if Is_Procedure then
New_External_Name (Chars (Obj_Id), Suffix => "_old")); Block_Decls := New_List (Decl);
New_Decls := New_List ( -- Generate:
Make_Object_Declaration (Loc, -- Current_Comp : Comp_Typ := Saved_Comp;
Defining_Identifier => Old_Id,
Constant_Present => True,
Object_Definition => New_Reference_To (Obj_Typ, Loc),
Expression => Unchecked_Convert_To (Obj_Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (At_Load_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address))))),
Make_Object_Declaration (Loc,
Defining_Identifier => Copy_Id,
Object_Definition => New_Reference_To (Obj_Typ, Loc),
Expression => New_Reference_To (Old_Id, Loc)));
-- Step 2: Create an exit statement of the loop statement generated Current_Comp :=
-- in step 3. Make_Defining_Identifier (Loc,
New_External_Name (Chars (Comp), Suffix => "_current"));
-- Generate (for Typ_Size = 32): Append_To (Block_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Current_Comp,
Object_Definition => New_Reference_To (Comp_Typ, Loc),
Expression => New_Reference_To (Saved_Comp, Loc)));
-- exit when System.Atomic_Primitives.Atomic_Compare_Exchange_32 -- Protected function
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
Exit_Stmt := else
Make_Exit_Statement (Loc, Append_To (Decls, Decl);
Condition => Current_Comp := Saved_Comp;
Make_Function_Call (Loc, end if;
Name => New_Reference_To (At_Comp_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Old_Id, Loc)),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Copy_Id, Loc)))));
-- Check the last statement is a return statement
if Nkind (Last (New_Stmts)) = N_Simple_Return_Statement then
Rewrite (Last (New_Stmts), Exit_Stmt);
else
Append_To (New_Stmts, Exit_Stmt);
end if;
-- Step 3: Create the loop statement which encloses a block Process_Stmts
-- declaration that contains all the statements of the original (Stmts, Compare, Unsigned, Comp, Saved_Comp, Current_Comp);
-- procedure body.
-- Generate: -- Generate:
-- exit when System.Atomic_Primitives.Atomic_Compare_Exchange
-- (Comp'Address,
-- Interfaces.Unsigned (Saved_Comp),
-- Interfaces.Unsigned (Current_Comp))
-- loop if Is_Procedure then
-- declare Stmt :=
-- < New_Decls > Make_Exit_Statement (Loc,
-- begin Condition =>
-- < New_Stmts > Make_Function_Call (Loc,
-- end; Name =>
-- end loop; New_Reference_To (Compare, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Comp, Loc),
Attribute_Name => Name_Address),
New_Stmts := New_List ( Unchecked_Convert_To (Unsigned,
Make_Loop_Statement (Loc, New_Reference_To (Saved_Comp, Loc)),
Statements => New_List (
Make_Block_Statement (Loc,
Declarations => New_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_Stmts))),
End_Label => Empty));
-- Append the label to the statements of the loop when needed Unchecked_Convert_To (Unsigned,
New_Reference_To (Current_Comp, Loc)))));
if Present (Label) then -- Small optimization: transform the default return statement
Append_To (Statements (First (New_Stmts)), Label); -- of a procedure into the atomic exit statement.
end if;
-- Function case if Nkind (Last (Stmts)) = N_Simple_Return_Statement then
Rewrite (Last (Stmts), Stmt);
else
Append_To (Stmts, Stmt);
end if;
end if;
else -- Create the declaration of the label used to skip the rest of
case Typ_Size is -- the source statements when the object state changes.
when 8 =>
At_Load_Id := RTE (RE_Atomic_Load_8);
when 16 =>
At_Load_Id := RTE (RE_Atomic_Load_16);
when 32 =>
At_Load_Id := RTE (RE_Atomic_Load_32);
when 64 =>
At_Load_Id := RTE (RE_Atomic_Load_64);
when others => null;
end case;
-- Define a copy of the protected object which replaces all the if Present (Label_Id) then
-- references to the object present in the body of the function. Label := Make_Label (Loc, Label_Id);
-- Generate: Append_To (Decls,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Label_Id),
Label_Construct => Label));
-- Obj_Copy : constant Obj_Typ := Append_To (Stmts, Label);
-- Obj_Typ! end if;
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
Append_To (Decls, -- Generate:
Make_Object_Declaration (Loc, -- loop
Defining_Identifier => Copy_Id, -- declare
Constant_Present => True, -- <Decls>
Object_Definition => New_Reference_To (Obj_Typ, Loc), -- begin
Expression => Unchecked_Convert_To (Obj_Typ, -- <Stmts>
Make_Function_Call (Loc, -- end;
Name => New_Reference_To (At_Load_Id, Loc), -- end loop;
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc, if Is_Procedure then
Prefix => New_Reference_To (Obj_Id, Loc), Stmts := New_List (
Attribute_Name => Name_Address)))))); Make_Loop_Statement (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Declarations => Block_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts))),
End_Label => Empty));
end if;
end;
end if; end if;
<< Continue >> -- Add renamings for the protection object, discriminals, privals and
-- Add renamings for the Protection object, discriminals, privals and
-- the entry index constant for use by debugger. -- the entry index constant for use by debugger.
Debug_Private_Data_Declarations (Decls); Debug_Private_Data_Declarations (Decls);
...@@ -3694,15 +3657,14 @@ package body Exp_Ch9 is ...@@ -3694,15 +3657,14 @@ package body Exp_Ch9 is
-- Make an unprotected version of the subprogram for use within the same -- Make an unprotected version of the subprogram for use within the same
-- object, with new name and extra parameter representing the object. -- object, with new name and extra parameter representing the object.
New_Body := return
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode),
Declarations => Decls, Declarations => Decls,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_Stmts)); Statements => Stmts));
return New_Body;
end Build_Lock_Free_Unprotected_Subprogram_Body; end Build_Lock_Free_Unprotected_Subprogram_Body;
------------------------- -------------------------
...@@ -5436,21 +5398,6 @@ package body Exp_Ch9 is ...@@ -5436,21 +5398,6 @@ package body Exp_Ch9 is
end loop; end loop;
end Collect_Entry_Families; end Collect_Entry_Families;
-------------
-- Comp_Of --
-------------
function Comp_Of (Sub_Body : Node_Id) return Entity_Id is
begin
for Sub_Id in 1 .. LF_Sub_Table.Last loop
if Sub_Body = LF_Sub_Table.Table (Sub_Id).Sub_Body then
return LF_Sub_Table.Table (Sub_Id).Comp_Id;
end if;
end loop;
return Empty;
end Comp_Of;
----------------------- -----------------------
-- Concurrent_Object -- -- Concurrent_Object --
----------------------- -----------------------
...@@ -8468,7 +8415,7 @@ package body Exp_Ch9 is ...@@ -8468,7 +8415,7 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Pid : constant Entity_Id := Corresponding_Spec (N); Pid : constant Entity_Id := Corresponding_Spec (N);
Lock_Free_On : constant Boolean := Allow_Lock_Free_Implementation (N); Lock_Free_On : constant Boolean := Allows_Lock_Free_Implementation (N);
-- This flag indicates whether the lock free implementation is active -- This flag indicates whether the lock free implementation is active
Current_Node : Node_Id; Current_Node : Node_Id;
......
gcc/ada/lib-writ.adb
...@@ -197,8 +197,9 @@ package body Lib.Writ is ...@@ -197,8 +197,9 @@ package body Lib.Writ is
-- Array of flags to show which units have Elaborate_All_Desirable set -- Array of flags to show which units have Elaborate_All_Desirable set
type Yes_No is (Unknown, Yes, No); type Yes_No is (Unknown, Yes, No);
Implicit_With : array (Units.First .. Last_Unit) of Yes_No; Implicit_With : array (Units.First .. Last_Unit) of Yes_No;
-- Indicates if an implicit with has been given for the unit. Yes if
-- certainly present, no if certainly absent, unkonwn if not known.
Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2)); Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2));
-- Sorted table of source dependencies. One extra entry in case we -- Sorted table of source dependencies. One extra entry in case we
...@@ -284,7 +285,6 @@ package body Lib.Writ is ...@@ -284,7 +285,6 @@ package body Lib.Writ is
if Implicit_With (Unum) /= Yes then if Implicit_With (Unum) /= Yes then
if Implicit_With_From_Instantiation (Item) then if Implicit_With_From_Instantiation (Item) then
Implicit_With (Unum) := Yes; Implicit_With (Unum) := Yes;
else else
Implicit_With (Unum) := No; Implicit_With (Unum) := No;
end if; end if;
......
gcc/ada/lib-xref.adb
...@@ -1731,9 +1731,9 @@ package body Lib.Xref is ...@@ -1731,9 +1731,9 @@ package body Lib.Xref is
-- since at the time the reference or definition is made, private -- since at the time the reference or definition is made, private
-- types may be swapped, and the Sloc value may be incorrect. We -- types may be swapped, and the Sloc value may be incorrect. We
-- also set up the pointer vector for the sort. -- also set up the pointer vector for the sort.
-- For user-defined operators we need to skip the initial
-- quote and point to the first character of the name, for -- For user-defined operators we need to skip the initial quote and
-- navigation purposes. -- point to the first character of the name, for navigation purposes.
for J in 1 .. Nrefs loop for J in 1 .. Nrefs loop
declare declare
......
gcc/ada/sem_ch12.adb
...@@ -7790,6 +7790,7 @@ package body Sem_Ch12 is ...@@ -7790,6 +7790,7 @@ package body Sem_Ch12 is
-- Take care to prevent direct cyclic with's -- Take care to prevent direct cyclic with's
if Lib_Unit /= Current_Unit then if Lib_Unit /= Current_Unit then
-- Do not add a unit if it is already in the context -- Do not add a unit if it is already in the context
Clause := First (Current_Context); Clause := First (Current_Context);
......
gcc/ada/sem_ch3.adb
...@@ -7755,6 +7755,7 @@ package body Sem_Ch3 is ...@@ -7755,6 +7755,7 @@ package body Sem_Ch3 is
declare declare
Parent_Full : Entity_Id; Parent_Full : Entity_Id;
begin begin
-- Ekind (Parent_Base) is not necessarily E_Record_Type since -- Ekind (Parent_Base) is not necessarily E_Record_Type since
-- Parent_Base can be a private type or private extension. Go -- Parent_Base can be a private type or private extension. Go
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment