diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-05-15 09:29:46 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-05-15 09:29:46 +0000 |
| commit | 7413d80df0db9a5082f700e04318b9d639f10b5c (patch) | |
| tree | 4a1bddd2f4929ab05a86932cff22860124f1fb69 | |
| parent | f74ffaae4fc78497c6bf3edb8c5ea7d3ae90d8cb (diff) | |
| download | gcc-7413d80df0db9a5082f700e04318b9d639f10b5c.tar.gz | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@187505 138bc75d-0d04-0410-961f-82ee72b054a4
| -rw-r--r-- | gcc/ada/ChangeLog | 41 | ||||
| -rw-r--r-- | gcc/ada/aspects.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/aspects.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 890 | ||||
| -rw-r--r-- | gcc/ada/g-comlin.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/g-comlin.ads | 92 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/s-atopri.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 375 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.ads | 34 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 1 |
16 files changed, 942 insertions, 628 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e1c40a95843..9f31c7543f9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +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 diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index b155a08714f..86e70917d16 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -242,11 +242,13 @@ package body Aspects is 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, @@ -259,6 +261,7 @@ package body Aspects is 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, @@ -266,24 +269,12 @@ package body Aspects is 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, @@ -295,12 +286,21 @@ package body Aspects is 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, @@ -316,6 +316,7 @@ package body Aspects is 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, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 781651feeb9..523412bd0e8 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -142,7 +142,12 @@ package Aspects is 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 @@ -182,6 +187,7 @@ package Aspects is 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, @@ -352,6 +358,7 @@ package Aspects is 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, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 0f597a1f941..b7ffe58fd59 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -452,6 +452,7 @@ package body Einfo is -- 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 @@ -525,7 +526,6 @@ package body Einfo is -- Has_Anonymous_Master Flag253 -- Is_Implementation_Defined Flag254 - -- (unused) Flag188 -- (unused) Flag201 ----------------------- @@ -2794,6 +2794,12 @@ package body Einfo is 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); @@ -5358,16 +5364,22 @@ package body Einfo is 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); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d07be8124cd..01037a5c005 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3878,6 +3878,12 @@ package Einfo is -- 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 @@ -5601,6 +5607,7 @@ package Einfo is -- 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) @@ -6405,6 +6412,7 @@ package Einfo is 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; @@ -7001,6 +7009,7 @@ package Einfo is 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); @@ -7746,6 +7755,7 @@ package Einfo is 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); @@ -8148,6 +8158,7 @@ package Einfo is 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); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index dfd0a067b15..238469ce79c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4602,6 +4602,7 @@ package body Exp_Ch7 is 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; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 8ea71916e26..244936c7e16 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -272,6 +272,8 @@ package Exp_Ch7 is 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 -- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9d21af2accc..1f9f45890f2 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -25,7 +25,6 @@ with Atree; use Atree; with Checks; use Checks; -with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -52,6 +51,7 @@ with Sem; use Sem; 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; @@ -61,7 +61,6 @@ with Sinfo; use Sinfo; 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; @@ -77,37 +76,6 @@ package body Exp_Ch9 is 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 -- ----------------------- @@ -142,20 +110,6 @@ package body Exp_Ch9 is -- 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 @@ -828,220 +782,6 @@ package body Exp_Ch9 is 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 -- ----------------------- @@ -3228,7 +2968,8 @@ package body Exp_Ch9 is -- 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> @@ -3496,19 +3237,33 @@ package body Exp_Ch9 is 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 @@ -3537,26 +3292,43 @@ package body Exp_Ch9 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 @@ -3564,7 +3336,7 @@ package body Exp_Ch9 is Block_Decls := New_List (Decl); -- Generate: - -- Current_Comp : Comp_Typ := Saved_Comp; + -- Current_Comp : Comp_Type := Saved_Comp; Current_Comp := Make_Defining_Identifier (Loc, @@ -3573,7 +3345,7 @@ package body Exp_Ch9 is 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 @@ -3645,6 +3417,9 @@ package body Exp_Ch9 is if Is_Procedure then Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Atomic_Synchronize), Loc)), Make_Loop_Statement (Loc, Statements => New_List ( Make_Block_Statement (Loc, @@ -8423,7 +8198,7 @@ package body Exp_Ch9 is 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; @@ -8554,7 +8329,7 @@ package body Exp_Ch9 is 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); @@ -8581,7 +8356,7 @@ package body Exp_Ch9 is -- 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)); @@ -8765,10 +8540,13 @@ package body Exp_Ch9 is -- 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; @@ -8926,108 +8704,6 @@ package body Exp_Ch9 is 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 @@ -9144,10 +8820,117 @@ package body Exp_Ch9 is 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; @@ -13149,9 +12932,12 @@ package body Exp_Ch9 is 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; @@ -13612,191 +13398,200 @@ package body Exp_Ch9 is 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 @@ -13868,15 +13663,18 @@ package body Exp_Ch9 is 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 diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index 8615b024f23..723ff120ff6 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -1343,7 +1343,7 @@ package body GNAT.Command_Line is 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; @@ -1390,7 +1390,7 @@ package body GNAT.Command_Line is 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; @@ -1415,7 +1415,7 @@ package body GNAT.Command_Line is 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; @@ -3233,7 +3233,9 @@ package body GNAT.Command_Line is 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)); diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index c3479bbfb42..c4b290e5567 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -181,16 +181,20 @@ -- ... -- 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 @@ -203,13 +207,13 @@ -- 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 @@ -263,8 +267,8 @@ -- 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: @@ -308,18 +312,18 @@ package GNAT.Command_Line is 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 @@ -451,9 +455,9 @@ package GNAT.Command_Line is -- 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; @@ -559,8 +563,8 @@ package GNAT.Command_Line is -- 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; @@ -609,9 +613,9 @@ package GNAT.Command_Line is -- -- 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. @@ -633,11 +637,13 @@ package GNAT.Command_Line is -- 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; @@ -649,14 +655,14 @@ package GNAT.Command_Line is 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; @@ -667,11 +673,10 @@ package GNAT.Command_Line is 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; @@ -705,15 +710,14 @@ package GNAT.Command_Line is (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; @@ -823,7 +827,7 @@ package GNAT.Command_Line is -- 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 @@ -947,6 +951,7 @@ package GNAT.Command_Line is --------------- -- Iteration -- --------------- + -- When a command line was created with the above, you can then iterate -- over its contents using the following iterator. @@ -992,6 +997,7 @@ package GNAT.Command_Line is -- create an Opt_Parser. -- -- Args must be freed by the caller. + -- -- Expanded has the same meaning as in Start. private diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index e02f575d7d5..a01505c709c 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -739,6 +739,8 @@ package Rtsfind is 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 @@ -1960,6 +1962,8 @@ package Rtsfind is 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, diff --git a/gcc/ada/s-atopri.ads b/gcc/ada/s-atopri.ads index c8c75f2ff72..3b87eb28125 100644 --- a/gcc/ada/s-atopri.ads +++ b/gcc/ada/s-atopri.ads @@ -29,7 +29,10 @@ -- -- ------------------------------------------------------------------------------ --- ??? 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; @@ -119,4 +122,6 @@ package System.Atomic_Primitives is 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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 3c3cce275e7..c8b987e93cd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -926,16 +926,40 @@ package body Sem_Ch13 is 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 diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 72ce1c0e9d1..a91f494152f 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -23,13 +23,16 @@ -- -- ------------------------------------------------------------------------------ +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; @@ -64,6 +67,29 @@ package body Sem_Ch9 is -- 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, @@ -91,6 +117,304 @@ package body Sem_Ch9 is -- 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 -- ----------------------------- @@ -1057,6 +1381,7 @@ package body Sem_Ch9 is 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; @@ -1130,6 +1455,42 @@ package body Sem_Ch9 is 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; ---------------------------------- @@ -1347,6 +1708,16 @@ package body Sem_Ch9 is 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 @@ -1840,10 +2211,6 @@ package body Sem_Ch9 is -- disastrous result. Analyze_Protected_Type_Declaration (N); - - if Has_Aspects (N) then - Analyze_Aspect_Specifications (N, Id); - end if; end Analyze_Single_Protected_Declaration; ------------------------------------- diff --git a/gcc/ada/sem_ch9.ads b/gcc/ada/sem_ch9.ads index 34e921f69b6..5cb7916974a 100644 --- a/gcc/ada/sem_ch9.ads +++ b/gcc/ada/sem_ch9.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Table; with Types; use Types; package Sem_Ch9 is @@ -52,4 +53,35 @@ 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; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index b0f8736ff23..c402967e733 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -142,6 +142,7 @@ package Snames is 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 + $; |