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

[multiple changes] 

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

From-SVN: r187505
This commit is contained in:
Arnaud Charlet 2012-05-15 11:29:46 +02:00
parent db664118be
commit 88e7531beb
16 changed files with 943 additions and 629 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/ChangeLog
View File

@ -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> 2012-05-15 Hristian Kirtchev <kirtchev@adacore.com>
* a-calend.adb (Day_Of_Week): The routine once again treats * a-calend.adb (Day_Of_Week): The routine once again treats

31
gcc/ada/aspects.adb
View File

@ -242,11 +242,13 @@ package body Aspects is
Aspect_Ada_2012 => Aspect_Ada_2005, Aspect_Ada_2012 => Aspect_Ada_2005,
Aspect_Address => Aspect_Address, Aspect_Address => Aspect_Address,
Aspect_Alignment => Aspect_Alignment, Aspect_Alignment => Aspect_Alignment,
Aspect_All_Calls_Remote => Aspect_All_Calls_Remote,
Aspect_Asynchronous => Aspect_Asynchronous, Aspect_Asynchronous => Aspect_Asynchronous,
Aspect_Atomic => Aspect_Atomic, Aspect_Atomic => Aspect_Atomic,
Aspect_Atomic_Components => Aspect_Atomic_Components, Aspect_Atomic_Components => Aspect_Atomic_Components,
Aspect_Attach_Handler => Aspect_Attach_Handler, Aspect_Attach_Handler => Aspect_Attach_Handler,
Aspect_Bit_Order => Aspect_Bit_Order, Aspect_Bit_Order => Aspect_Bit_Order,
Aspect_Compiler_Unit => Aspect_Compiler_Unit,
Aspect_Component_Size => Aspect_Component_Size, Aspect_Component_Size => Aspect_Component_Size,
Aspect_Constant_Indexing => Aspect_Constant_Indexing, Aspect_Constant_Indexing => Aspect_Constant_Indexing,
Aspect_Contract_Case => Aspect_Contract_Case, Aspect_Contract_Case => Aspect_Contract_Case,
@ -259,6 +261,7 @@ package body Aspects is
Aspect_Discard_Names => Aspect_Discard_Names, Aspect_Discard_Names => Aspect_Discard_Names,
Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate => Aspect_Predicate, Aspect_Dynamic_Predicate => Aspect_Predicate,
Aspect_Elaborate_Body => Aspect_Elaborate_Body,
Aspect_External_Tag => Aspect_External_Tag, Aspect_External_Tag => Aspect_External_Tag,
Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
Aspect_Implicit_Dereference => Aspect_Implicit_Dereference, Aspect_Implicit_Dereference => Aspect_Implicit_Dereference,
@ -266,24 +269,12 @@ package body Aspects is
Aspect_Independent_Components => Aspect_Independent_Components, Aspect_Independent_Components => Aspect_Independent_Components,
Aspect_Inline => Aspect_Inline, Aspect_Inline => Aspect_Inline,
Aspect_Inline_Always => Aspect_Inline, Aspect_Inline_Always => Aspect_Inline,
Aspect_Input => Aspect_Input,
Aspect_Interrupt_Handler => Aspect_Interrupt_Handler, Aspect_Interrupt_Handler => Aspect_Interrupt_Handler,
Aspect_Interrupt_Priority => Aspect_Interrupt_Priority, 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_Invariant => Aspect_Invariant,
Aspect_Iterator_Element => Aspect_Iterator_Element,
Aspect_Lock_Free => Aspect_Lock_Free,
Aspect_Machine_Radix => Aspect_Machine_Radix, Aspect_Machine_Radix => Aspect_Machine_Radix,
Aspect_No_Return => Aspect_No_Return, Aspect_No_Return => Aspect_No_Return,
Aspect_Object_Size => Aspect_Object_Size, Aspect_Object_Size => Aspect_Object_Size,
@ -295,12 +286,21 @@ package body Aspects is
Aspect_Pre => Aspect_Pre, Aspect_Pre => Aspect_Pre,
Aspect_Precondition => Aspect_Pre, Aspect_Precondition => Aspect_Pre,
Aspect_Predicate => Aspect_Predicate, Aspect_Predicate => Aspect_Predicate,
Aspect_Preelaborate => Aspect_Preelaborate,
Aspect_Preelaborate_05 => Aspect_Preelaborate_05,
Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization, Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
Aspect_Priority => Aspect_Priority, 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_Pure_Function => Aspect_Pure_Function,
Aspect_Remote_Access_Type => Aspect_Remote_Access_Type, 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_Read => Aspect_Read,
Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order,
Aspect_Shared => Aspect_Atomic, Aspect_Shared => Aspect_Atomic,
Aspect_Shared_Passive => Aspect_Shared_Passive,
Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool, Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type, Aspect_Simple_Storage_Pool_Type => Aspect_Simple_Storage_Pool_Type,
Aspect_Size => Aspect_Size, Aspect_Size => Aspect_Size,
@ -316,6 +316,7 @@ package body Aspects is
Aspect_Type_Invariant => Aspect_Invariant, Aspect_Type_Invariant => Aspect_Invariant,
Aspect_Unchecked_Union => Aspect_Unchecked_Union, Aspect_Unchecked_Union => Aspect_Unchecked_Union,
Aspect_Universal_Aliasing => Aspect_Universal_Aliasing, Aspect_Universal_Aliasing => Aspect_Universal_Aliasing,
Aspect_Universal_Data => Aspect_Universal_Data,
Aspect_Unmodified => Aspect_Unmodified, Aspect_Unmodified => Aspect_Unmodified,
Aspect_Unreferenced => Aspect_Unreferenced, Aspect_Unreferenced => Aspect_Unreferenced,
Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects, Aspect_Unreferenced_Objects => Aspect_Unreferenced_Objects,

9
gcc/ada/aspects.ads
View File

@ -142,7 +142,12 @@ package Aspects is
Aspect_Unreferenced, -- GNAT Aspect_Unreferenced, -- GNAT
Aspect_Unreferenced_Objects, -- GNAT Aspect_Unreferenced_Objects, -- GNAT
Aspect_Volatile, 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 -- The following array indicates aspects that accept 'Class
@ -182,6 +187,7 @@ package Aspects is
Aspect_Dimension_System => True, Aspect_Dimension_System => True,
Aspect_Favor_Top_Level => True, Aspect_Favor_Top_Level => True,
Aspect_Inline_Always => True, Aspect_Inline_Always => True,
Aspect_Lock_Free => True,
Aspect_Object_Size => True, Aspect_Object_Size => True,
Aspect_Persistent_BSS => True, Aspect_Persistent_BSS => True,
Aspect_Predicate => True, Aspect_Predicate => True,
@ -352,6 +358,7 @@ package Aspects is
Aspect_Interrupt_Priority => Name_Interrupt_Priority, Aspect_Interrupt_Priority => Name_Interrupt_Priority,
Aspect_Invariant => Name_Invariant, Aspect_Invariant => Name_Invariant,
Aspect_Iterator_Element => Name_Iterator_Element, Aspect_Iterator_Element => Name_Iterator_Element,
Aspect_Lock_Free => Name_Lock_Free,
Aspect_Machine_Radix => Name_Machine_Radix, Aspect_Machine_Radix => Name_Machine_Radix,
Aspect_No_Return => Name_No_Return, Aspect_No_Return => Name_No_Return,
Aspect_Object_Size => Name_Object_Size, Aspect_Object_Size => Name_Object_Size,

24
gcc/ada/einfo.adb
View File

@ -452,6 +452,7 @@ package body Einfo is
-- Is_Ada_2005_Only Flag185 -- Is_Ada_2005_Only Flag185
-- Is_Interface Flag186 -- Is_Interface Flag186
-- Has_Constrained_Partial_View Flag187 -- Has_Constrained_Partial_View Flag187
-- Uses_Lock_Free Flag188
-- Is_Pure_Unit_Access_Type Flag189 -- Is_Pure_Unit_Access_Type Flag189
-- Has_Specified_Stream_Input Flag190 -- Has_Specified_Stream_Input Flag190
@ -525,7 +526,6 @@ package body Einfo is
-- Has_Anonymous_Master Flag253 -- Has_Anonymous_Master Flag253
-- Is_Implementation_Defined Flag254 -- Is_Implementation_Defined Flag254
-- (unused) Flag188
-- (unused) Flag201 -- (unused) Flag201
----------------------- -----------------------
@ -2794,6 +2794,12 @@ package body Einfo is
return Flag222 (Id); return Flag222 (Id);
end Used_As_Generic_Actual; 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 function Uses_Sec_Stack (Id : E) return B is
begin begin
return Flag95 (Id); return Flag95 (Id);
@ -5358,16 +5364,22 @@ package body Einfo is
Set_Node16 (Id, V); Set_Node16 (Id, V);
end Set_Unset_Reference; 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 procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is
begin begin
Set_Flag222 (Id, V); Set_Flag222 (Id, V);
end Set_Used_As_Generic_Actual; 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 procedure Set_Warnings_Off (Id : E; V : B := True) is
begin begin
Set_Flag96 (Id, V); Set_Flag96 (Id, V);

11
gcc/ada/einfo.ads
View File

@ -3878,6 +3878,12 @@ package Einfo is
-- Present in all entities, set if the entity is used as an argument to -- Present in all entities, set if the entity is used as an argument to
-- a generic instantiation. Used to tune certain warning messages. -- 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) -- Uses_Sec_Stack (Flag95)
-- Present in scope entities (blocks,functions, procedures, tasks, -- Present in scope entities (blocks,functions, procedures, tasks,
-- entries). Set to True when secondary stack is used in this scope and -- entries). Set to True when secondary stack is used in this scope and
@ -5601,6 +5607,7 @@ package Einfo is
-- Stored_Constraint (Elist23) -- Stored_Constraint (Elist23)
-- Has_Interrupt_Handler (synth) -- Has_Interrupt_Handler (synth)
-- Sec_Stack_Needed_For_Return (Flag167) ??? -- Sec_Stack_Needed_For_Return (Flag167) ???
-- Uses_Lock_Free (Flag188)
-- Uses_Sec_Stack (Flag95) ??? -- Uses_Sec_Stack (Flag95) ???
-- Has_Entries (synth) -- Has_Entries (synth)
-- Number_Entries (synth) -- Number_Entries (synth)
@ -6405,6 +6412,7 @@ package Einfo is
function Universal_Aliasing (Id : E) return B; function Universal_Aliasing (Id : E) return B;
function Unset_Reference (Id : E) return N; function Unset_Reference (Id : E) return N;
function Used_As_Generic_Actual (Id : E) return B; 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 Uses_Sec_Stack (Id : E) return B;
function Vax_Float (Id : E) return B; function Vax_Float (Id : E) return B;
function Warnings_Off (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_Universal_Aliasing (Id : E; V : B := True);
procedure Set_Unset_Reference (Id : E; V : N); procedure Set_Unset_Reference (Id : E; V : N);
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True); 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_Uses_Sec_Stack (Id : E; V : B := True);
procedure Set_Warnings_Off (Id : E; V : B := True); procedure Set_Warnings_Off (Id : E; V : B := True);
procedure Set_Warnings_Off_Used (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 (Universal_Aliasing);
pragma Inline (Unset_Reference); pragma Inline (Unset_Reference);
pragma Inline (Used_As_Generic_Actual); pragma Inline (Used_As_Generic_Actual);
pragma Inline (Uses_Lock_Free);
pragma Inline (Uses_Sec_Stack); pragma Inline (Uses_Sec_Stack);
pragma Inline (Warnings_Off); pragma Inline (Warnings_Off);
pragma Inline (Warnings_Off_Used); pragma Inline (Warnings_Off_Used);
@ -8148,6 +8158,7 @@ package Einfo is
pragma Inline (Set_Universal_Aliasing); pragma Inline (Set_Universal_Aliasing);
pragma Inline (Set_Unset_Reference); pragma Inline (Set_Unset_Reference);
pragma Inline (Set_Used_As_Generic_Actual); pragma Inline (Set_Used_As_Generic_Actual);
pragma Inline (Set_Uses_Lock_Free);
pragma Inline (Set_Uses_Sec_Stack); pragma Inline (Set_Uses_Sec_Stack);
pragma Inline (Set_Warnings_Off); pragma Inline (Set_Warnings_Off);
pragma Inline (Set_Warnings_Off_Used); pragma Inline (Set_Warnings_Off_Used);

1
gcc/ada/exp_ch7.adb
View File

@ -4602,6 +4602,7 @@ package body Exp_Ch7 is
begin begin
return return
Is_Protected_Type (T) Is_Protected_Type (T)
and then not Uses_Lock_Free (T)
and then not Has_Entries (T) and then not Has_Entries (T)
and then Is_RTE (Find_Protection_Type (T), RE_Protection); and then Is_RTE (Find_Protection_Type (T), RE_Protection);
end Is_Simple_Protected_Type; end Is_Simple_Protected_Type;

4
gcc/ada/exp_ch7.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- 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; function Is_Simple_Protected_Type (T : Entity_Id) return Boolean;
-- Determine whether T denotes a protected type without entires whose -- Determine whether T denotes a protected type without entires whose
-- _object field is of type System.Tasking.Protected_Objects.Protection. -- _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 -- -- Transient Scope Management --

892
gcc/ada/exp_ch9.adb
View File

File diff suppressed because it is too large Load Diff

10
gcc/ada/g-comlin.adb
View File

@ -1343,7 +1343,7 @@ package body GNAT.Command_Line is
begin begin
if Switch /= "" or else Long_Switch /= "" then if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def Initialize_Switch_Def
(Def, Switch, Long_Switch, Help, Section, Argument); (Def, Switch, Long_Switch, Help, Section, Argument);
Add (Config, Def); Add (Config, Def);
end if; end if;
end Define_Switch; end Define_Switch;
@ -1390,7 +1390,7 @@ package body GNAT.Command_Line is
begin begin
if Switch /= "" or else Long_Switch /= "" then if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def 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_Output := Output.all'Unchecked_Access;
Def.Integer_Default := Default; Def.Integer_Default := Default;
Def.Integer_Initial := Initial; Def.Integer_Initial := Initial;
@ -1415,7 +1415,7 @@ package body GNAT.Command_Line is
begin begin
if Switch /= "" or else Long_Switch /= "" then if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def Initialize_Switch_Def
(Def, Switch, Long_Switch, Help, Section, Argument); (Def, Switch, Long_Switch, Help, Section, Argument);
Def.String_Output := Output.all'Unchecked_Access; Def.String_Output := Output.all'Unchecked_Access;
Add (Config, Def); Add (Config, Def);
end if; end if;
@ -3233,7 +3233,9 @@ package body GNAT.Command_Line is
end if; end if;
end if; end if;
else -- Long_Switch necessarily not null -- Def.Switch is null (Long_Switch must be non-null)
else
Decompose_Switch (Def.Long_Switch.all, P2, Last2); Decompose_Switch (Def.Long_Switch.all, P2, Last2);
Append (Result, Append (Result,
Def.Long_Switch (Def.Long_Switch'First .. Last2)); Def.Long_Switch (Def.Long_Switch'First .. Last2));

92
gcc/ada/g-comlin.ads
View File

@ -181,16 +181,20 @@
-- ... -- ...
-- Specifying the help message is optional, but makes it easy to then call -- Specifying the help message is optional, but makes it easy to then call
-- the function -- the function:
-- Display_Help (Config); -- Display_Help (Config);
-- that will display a properly formatted help message for your application, -- that will display a properly formatted help message for your application,
-- listing all possible switches. That way you have a single place in which -- 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 -- 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 the string to pass to Getopt and a subprogram to display the help.
-- Both will properly stay synchronized. -- 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); -- Getopt (Config, Callback'Access);
-- to parse the command line. The Callback will be called for each switch -- 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" -- found on the command line (in the case of our example, that is "-gnatwu"
-- and then "-gnatwv", not "-gnatwa" itself). This simplifies command line -- and then "-gnatwv", not "-gnatwa" itself). This simplifies command line
@ -203,13 +207,13 @@
-- Optimization : aliased Integer; -- Optimization : aliased Integer;
-- Verbose : aliased Boolean; -- Verbose : aliased Boolean;
--
-- Define_Switch (Config, Verbose'Access, -- Define_Switch (Config, Verbose'Access,
-- "-v", Long_Switch => "--verbose", -- "-v", Long_Switch => "--verbose",
-- Help => "Output extra verbose information"); -- Help => "Output extra verbose information");
-- Define_Switch (Config, Optimization'Access, -- Define_Switch (Config, Optimization'Access,
-- "-O?", Help => "Optimization level"); -- "-O?", Help => "Optimization level");
--
-- Getopt (Config); -- No callback -- Getopt (Config); -- No callback
-- Since all switches are handled automatically, we don't even need to pass -- 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 -- Some command line arguments can have parameters, which on a command line
-- appear as a separate argument that must immediately follow the switch. -- appear as a separate argument that must immediately follow the switch.
-- Since the subprograms in this package will reorganize the switches to group -- Since the subprograms in this package will reorganize the switches to group
-- them, you need to indicate what is a command line -- them, you need to indicate what is a command line parameter, and what is a
-- parameter, and what is a switch argument. -- switch argument.
-- This is done by passing an extra argument to Add_Switch, as in: -- 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; Stop_At_First_Non_Switch : Boolean := False;
Section_Delimiters : String := ""); Section_Delimiters : String := "");
-- The first procedure resets the internal state of the package to prepare -- 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 -- to rescan the parameters. It does not need to be called before the
-- use of Getopt (but it could be), but it must be called if you want to -- first use of Getopt (but it could be), but it must be called if you
-- start rescanning the command line parameters from the start. The -- want to start rescanning the command line parameters from the start.
-- optional parameter Switch_Char can be used to reset the switch -- The optional parameter Switch_Char can be used to reset the switch
-- character, e.g. to '/' for use in DOS-like systems. -- character, e.g. to '/' for use in DOS-like systems.
-- --
-- The second subprogram initializes a parser that takes its arguments from -- The second subprogram initializes a parser that takes its arguments
-- an array of strings rather than directly from the command line. In this -- from an array of strings rather than directly from the command line. In
-- case, the parser is responsible for freeing the strings stored 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 -- 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 -- 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 -- 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 -- 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. -- spaces.
-- --
-- Example -- Example
-- Getopt ("a b", Concatenate => False) -- Getopt ("a b", Concatenate => False)
-- If the command line is '-ab', exception Invalid_Switch will be -- If the command line is '-ab', exception Invalid_Switch will be
-- raised and Full_Switch will return "ab". -- raised and Full_Switch will return "ab".
function Get_Argument function Get_Argument
(Do_Expansion : Boolean := False; (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 section name should not include the leading '-'. So for instance in
-- the case of gnatmake we would use: -- the case of gnatmake we would use:
-- --
-- Define_Section (Config, "cargs"); -- Define_Section (Config, "cargs");
-- Define_Section (Config, "bargs"); -- Define_Section (Config, "bargs");
procedure Define_Alias procedure Define_Alias
(Config : in out Command_Line_Configuration; (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 -- Switch and Long_Switch (when specified) are aliases and can be used
-- interchangeably. There is no check that they both take an argument or -- interchangeably. There is no check that they both take an argument or
-- both take no argument. -- both take no argument. Switch can be set to "*" to indicate that any
-- Switch can be set to "*" to indicate that any switch is supported (in -- switch is supported (in which case Getopt will return '*', see its
-- which case Getopt will return '*', see its documentation). -- documentation).
-- --
-- Help is used by the Display_Help procedure to describe the supported -- Help is used by the Display_Help procedure to describe the supported
-- switches. -- switches.
@ -633,11 +637,13 @@ package GNAT.Command_Line is
-- See Define_Switch for a description of the parameters. -- See Define_Switch for a description of the parameters.
-- When the switch is found on the command line, Getopt will set -- When the switch is found on the command line, Getopt will set
-- Output.all to Value. -- Output.all to Value.
--
-- Output is always initially set to "not Value", so that if the switch is -- 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. -- not found on the command line, Output still has a valid value.
-- The switch must not take any parameter. -- 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 procedure Define_Switch
(Config : in out Command_Line_Configuration; (Config : in out Command_Line_Configuration;
@ -649,14 +655,14 @@ package GNAT.Command_Line is
Initial : Integer := 0; Initial : Integer := 0;
Default : Integer := 1; Default : Integer := 1;
Argument : String := "ARG"); Argument : String := "ARG");
-- See Define_Switch for a description of the parameters. -- See Define_Switch for a description of the parameters. When the
-- When the switch is found on the command line, Getopt will set -- switch is found on the command line, Getopt will set Output.all to the
-- Output.all to the value of the switch's parameter. If the parameter is -- value of the switch's parameter. If the parameter is not an integer,
-- not an integer, Invalid_Parameter is raised. -- Invalid_Parameter is raised.
-- Output is always initialized to Initial. If the switch has an optional -- 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 -- argument which isn't specified by the user, then Output will be set to
-- Default. -- Default. The switch must accept an argument.
-- The switch must accept an argument.
procedure Define_Switch procedure Define_Switch
(Config : in out Command_Line_Configuration; (Config : in out Command_Line_Configuration;
@ -667,11 +673,10 @@ package GNAT.Command_Line is
Section : String := ""; Section : String := "";
Argument : String := "ARG"); Argument : String := "ARG");
-- Set Output to the value of the switch's parameter when the switch is -- Set Output to the value of the switch's parameter when the switch is
-- found on the command line. -- found on the command line. Output is always initialized to the empty
-- Output is always initialized to the empty string if it does not have -- string if it does not have a value already (otherwise it is left as is
-- a value already (otherwise it is left as is so that you can specify the -- so that you can specify the default value directly in the declaration
-- default value directly in the declaration of the variable). -- of the variable). The switch must accept an argument.
-- The switch must accept an argument.
procedure Set_Usage procedure Set_Usage
(Config : in out Command_Line_Configuration; (Config : in out Command_Line_Configuration;
@ -705,15 +710,14 @@ package GNAT.Command_Line is
(Switch : String; (Switch : String;
Parameter : String; Parameter : String;
Section : String); Section : String);
-- Called when a switch is found on the command line. -- Called when a switch is found on the command line. Switch includes
-- [Switch] includes any leading '-' that was specified in Define_Switch. -- any leading '-' that was specified in Define_Switch. This is slightly
-- This is slightly different from the functional version of Getopt above, -- different from the functional version of Getopt above, for which
-- for which Full_Switch omits the first leading '-'. -- Full_Switch omits the first leading '-'.
Exit_From_Command_Line : exception; Exit_From_Command_Line : exception;
-- Emitted when the program should exit. -- Emitted when the program should exit. This is called when Getopt below
-- This is called when Getopt below has seen -h, --help or an invalid -- has seen -h, --help or an invalid switch.
-- switch.
procedure Getopt procedure Getopt
(Config : Command_Line_Configuration; (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 -- If the command line has sections (such as -bargs -cargs), then they
-- should be listed in the Sections parameter (as "-bargs -cargs"). -- 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 -- 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 -- the configuration via Define_Switch), and the configuration wasn't set
@ -947,6 +951,7 @@ package GNAT.Command_Line is
--------------- ---------------
-- Iteration -- -- Iteration --
--------------- ---------------
-- When a command line was created with the above, you can then iterate -- When a command line was created with the above, you can then iterate
-- over its contents using the following iterator. -- over its contents using the following iterator.
@ -992,6 +997,7 @@ package GNAT.Command_Line is
-- create an Opt_Parser. -- create an Opt_Parser.
-- --
-- Args must be freed by the caller. -- Args must be freed by the caller.
--
-- Expanded has the same meaning as in Start. -- Expanded has the same meaning as in Start.
private private

4
gcc/ada/rtsfind.ads
View File

@ -739,6 +739,8 @@ package Rtsfind is
RE_Atomic_Load_16, -- System.Atomic_Primitives RE_Atomic_Load_16, -- System.Atomic_Primitives
RE_Atomic_Load_32, -- System.Atomic_Primitives RE_Atomic_Load_32, -- System.Atomic_Primitives
RE_Atomic_Load_64, -- 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_Uint8, -- System.Atomic_Primitives
RE_Uint16, -- System.Atomic_Primitives RE_Uint16, -- System.Atomic_Primitives
RE_Uint32, -- 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_16 => System_Atomic_Primitives,
RE_Atomic_Load_32 => System_Atomic_Primitives, RE_Atomic_Load_32 => System_Atomic_Primitives,
RE_Atomic_Load_64 => 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_Uint8 => System_Atomic_Primitives,
RE_Uint16 => System_Atomic_Primitives, RE_Uint16 => System_Atomic_Primitives,
RE_Uint32 => System_Atomic_Primitives, RE_Uint32 => System_Atomic_Primitives,

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

@ -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 package System.Atomic_Primitives is
pragma Preelaborate; pragma Preelaborate;
@ -119,4 +122,6 @@ package System.Atomic_Primitives is
Model : Mem_Model := Seq_Cst) return uint64; Model : Mem_Model := Seq_Cst) return uint64;
pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8");
procedure Atomic_Synchronize;
pragma Import (Intrinsic, Atomic_Synchronize, "__sync_synchronize");
end System.Atomic_Primitives; end System.Atomic_Primitives;

36
gcc/ada/sem_ch13.adb
View File

@ -926,16 +926,40 @@ package body Sem_Ch13 is
when No_Aspect => when No_Aspect =>
raise Program_Error; raise Program_Error;
-- Aspects taking an optional boolean argument. For all of -- Aspects taking an optional boolean argument
-- 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.
when Boolean_Aspects => when Boolean_Aspects =>
Set_Is_Boolean_Aspect (Aspect); 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) if Present (Expr)
and then Is_False (Static_Boolean (Expr)) and then Is_False (Static_Boolean (Expr))
then then

375
gcc/ada/sem_ch9.adb
View File

@ -23,13 +23,16 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree; with Atree; use Atree;
with Checks; use Checks; with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9; with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists; with Elists; use Elists;
with Freeze; use Freeze; with Freeze; use Freeze;
with Layout; use Layout;
with Lib.Xref; use Lib.Xref; with Lib.Xref; use Lib.Xref;
with Namet; use Namet; with Namet; use Namet;
with Nlists; use Nlists; with Nlists; use Nlists;
@ -64,6 +67,29 @@ package body Sem_Ch9 is
-- Local Subprograms -- -- 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); procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
-- Given either a protected definition or a task definition in D, check -- Given either a protected definition or a task definition in D, check
-- the corresponding restriction parameter identifier R, and if it is set, -- 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 -- Utility to make visible in corresponding body the entities defined in
-- task, protected type declaration, or entry declaration. -- 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 -- -- Analyze_Abort_Statement --
----------------------------- -----------------------------
@ -1057,6 +1381,7 @@ package body Sem_Ch9 is
procedure Analyze_Protected_Body (N : Node_Id) is procedure Analyze_Protected_Body (N : Node_Id) is
Body_Id : constant Entity_Id := Defining_Identifier (N); Body_Id : constant Entity_Id := Defining_Identifier (N);
Aspect : Node_Id;
Last_E : Entity_Id; Last_E : Entity_Id;
Spec_Id : Entity_Id; Spec_Id : Entity_Id;
@ -1130,6 +1455,42 @@ package body Sem_Ch9 is
Check_References (Spec_Id); Check_References (Spec_Id);
Process_End_Label (N, 't', Ref_Id); Process_End_Label (N, 't', Ref_Id);
End_Scope; End_Scope;
-- Turn on/off the lock-free implementation for the protected object
-- Look for a Lock_Free aspect with a False expression that disables the
-- lock-free implementation.
Aspect := First (Aspect_Specifications (Parent (Spec_Id)));
while Present (Aspect) loop
if Get_Aspect_Id (Chars (Identifier (Aspect))) = Aspect_Lock_Free
and then Present (Expression (Aspect))
and then Entity (Expression (Aspect)) = Standard_False
then
return;
end if;
Next (Aspect);
end loop;
-- When a Lock_Free aspect forces the lock-free implementation, verify
-- the protected body meets all the restrictions, otherwise
-- Allows_Lock_Free_Implementation issues an error message.
if Uses_Lock_Free (Spec_Id) then
if not Allows_Lock_Free_Implementation (N, Complain => True) then
return;
end if;
-- In other cases, check both the protected declaration and body satisfy
-- the lock-free restrictions.
elsif Allows_Lock_Free_Implementation (Parent (Spec_Id))
and then Allows_Lock_Free_Implementation (N)
then
Set_Uses_Lock_Free (Spec_Id);
end if;
end Analyze_Protected_Body; end Analyze_Protected_Body;
---------------------------------- ----------------------------------
@ -1347,6 +1708,16 @@ package body Sem_Ch9 is
End_Scope; 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 -- Case of a completion of a private declaration
if T /= Def_Id if T /= Def_Id
@ -1840,10 +2211,6 @@ package body Sem_Ch9 is
-- disastrous result. -- disastrous result.
Analyze_Protected_Type_Declaration (N); Analyze_Protected_Type_Declaration (N);
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
end Analyze_Single_Protected_Declaration; end Analyze_Single_Protected_Declaration;
------------------------------------- -------------------------------------

34
gcc/ada/sem_ch9.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -23,6 +23,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Table;
with Types; use Types; with Types; use Types;
package Sem_Ch9 is package Sem_Ch9 is
@ -52,4 +53,35 @@ package Sem_Ch9 is
procedure Analyze_Terminate_Alternative (N : Node_Id); procedure Analyze_Terminate_Alternative (N : Node_Id);
procedure Analyze_Timed_Entry_Call (N : Node_Id); procedure Analyze_Timed_Entry_Call (N : Node_Id);
procedure Analyze_Triggering_Alternative (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; end Sem_Ch9;

1
gcc/ada/snames.ads-tmpl
View File

@ -142,6 +142,7 @@ package Snames is
Name_Dimension : constant Name_Id := N + $; Name_Dimension : constant Name_Id := N + $;
Name_Dimension_System : constant Name_Id := N + $; Name_Dimension_System : constant Name_Id := N + $;
Name_Dynamic_Predicate : 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_Post : constant Name_Id := N + $;
Name_Pre : constant Name_Id := N + $; Name_Pre : constant Name_Id := N + $;
Name_Static_Predicate : constant Name_Id := N + $; Name_Static_Predicate : constant Name_Id := N + $;