mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-11 06:20:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

[Ada] Enable lock free protected implementation by default

Browse Source 
In the past, the Lock_Free aspect of a protected type (including an
anonymous type) defaulted to False. In the case where an explicit
"Lock_Free => True" aspect specification would be legal, the aspect now
defaults to True (which means that a lock-free implementation is used to
implement the type's protected operations); this is like the previous
behavior of the compiler with the -gnatd9 switch specified. Support for
the Lock_Free attribute (which should not be confused with the Lock_Free
aspect) is removed.

gcc/ada/

	* debug.adb: Remove comment regarding the -gnatd9 switch.
	* doc/gnat_rm/implementation_defined_attributes.rst: Remove all
	mention of the Lock_Free attribute.
	* gnat_rm.texi, gnat_ugn.texi: Regenerate.
	* exp_attr.adb, sem_attr.adb: Remove all mention of the former
	Attribute_Lock_Free enumeration element of the Attribute_Id type.
	* sem_ch9.adb
	(Allows_Lock_Free_Implementation): Remove the Debug_Flag_9 test.
	Return False in the case of a protected function whose result type
	requires use of the secondary stack.
	(Satisfies_Lock_Free_Requirements): This functions checks for
	certain constructs and returns False if one is found. In the case
	of a protected function, there is no need to check to see if the
	protected object is being modified. So it is ok to omit *some*
	checks in the case of a protected function. But other checks which
	are required (e.g., the test for a reference to a variable that is
	not part of the protected object) were being incorrectly omitted.
	This could result in accepting "Lock_Free => True" aspect
	specifications that should be rejected.
	* snames.adb-tmpl: Name_Lock_Free no longer requires special
	treatment in Get_Pragma_Id or Is_Pragma_Name (because it is no
	longer an attribute name).
	* snames.ads-tmpl: Move the declaration of Name_Lock_Free to
	reflect the fact that it is no longer the name of an attribute.
	Delete Attribute_Lock_Free from the Attribute_Id enumeration type.
This commit is contained in:
Steve Baird 2022-08-12 17:04:38 -07:00 committed by Marc Poulhiès
parent fc737a6c20
commit 71747dda9d
9 changed files with 728 additions and 795 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gcc/ada/debug.adb
View File

@ -201,7 +201,7 @@ package body Debug is
-- d6 Default access unconstrained to thin pointers
-- d7 Suppress version/source stamp/compilation time for -gnatv/-gnatl
-- d8 Force opposite endianness in packed stuff
-- d9 Allow lock free implementation
-- d9
-- d.1 Enable unnesting of nested procedures
-- d.2 Allow statements in declarative part

7
gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
View File

@ -606,13 +606,6 @@ in this example:
end Gen;
Attribute Lock_Free
===================
.. index:: Lock_Free
``P'Lock_Free``, where P is a protected object, returns True if a
pragma ``Lock_Free`` applies to P.
Attribute Loop_Entry
====================
.. index:: Loop_Entry

1
gcc/ada/exp_attr.adb
View File

@ -7970,7 +7970,6 @@ package body Exp_Attr is
| Attribute_Large
| Attribute_Last_Valid
| Attribute_Library_Level
| Attribute_Lock_Free
| Attribute_Machine_Emax
| Attribute_Machine_Emin
| Attribute_Machine_Mantissa

984
gcc/ada/gnat_rm.texi
View File

File diff suppressed because it is too large Load Diff

2
gcc/ada/gnat_ugn.texi
View File

@ -29317,8 +29317,8 @@ to permit their use in free software.
@printindex ge
@anchor{cf}@w{ }
@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
@anchor{cf}@w{ }
@c %**end of body
@bye

44
gcc/ada/sem_attr.adb
View File

@ -4697,19 +4697,6 @@ package body Sem_Attr is
Set_Etype (N, Standard_Boolean);
---------------
-- Lock_Free --
---------------
when Attribute_Lock_Free =>
Check_E0;
Set_Etype (N, Standard_Boolean);
if not Is_Protected_Type (P_Type) then
Error_Attr_P
("prefix of % attribute must be a protected object");
end if;
----------------
-- Loop_Entry --
----------------
@ -8338,15 +8325,6 @@ package body Sem_Attr is
return;
-- For Lock_Free, we apply the attribute to the type of the object.
-- This is allowed since we have already verified that the type is a
-- protected type.
elsif Id = Attribute_Lock_Free then
P_Entity := Etype (P);
-- No other attributes for objects are folded
else
Check_Expressions;
return;
@ -8476,7 +8454,6 @@ package body Sem_Attr is
Id = Attribute_Has_Access_Values or else
Id = Attribute_Has_Discriminants or else
Id = Attribute_Has_Tagged_Values or else
Id = Attribute_Lock_Free or else
Id = Attribute_Preelaborable_Initialization or else
Id = Attribute_Type_Class or else
Id = Attribute_Unconstrained_Array or else
@ -8595,7 +8572,7 @@ package body Sem_Attr is
-- only the First, Last and Length attributes are possibly static.
-- Atomic_Always_Lock_Free, Definite, Descriptor_Size, Has_Access_Values
-- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and
-- Has_Discriminants, Has_Tagged_Values, Type_Class, and
-- Unconstrained_Array are again exceptions, because they apply as well
-- to unconstrained types.
@ -8614,7 +8591,6 @@ package body Sem_Attr is
Id = Attribute_Has_Access_Values or else
Id = Attribute_Has_Discriminants or else
Id = Attribute_Has_Tagged_Values or else
Id = Attribute_Lock_Free or else
Id = Attribute_Preelaborable_Initialization or else
Id = Attribute_Type_Class or else
Id = Attribute_Unconstrained_Array or else
@ -9315,24 +9291,6 @@ package body Sem_Attr is
True);
end if;
---------------
-- Lock_Free --
---------------
when Attribute_Lock_Free => Lock_Free : declare
V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type));
begin
Rewrite (N, New_Occurrence_Of (V, Loc));
-- Analyze and resolve as boolean. Note that this attribute is a
-- static attribute in GNAT.
Analyze_And_Resolve (N, Standard_Boolean);
Static := True;
Set_Is_Static_Expression (N);
end Lock_Free;
----------
-- Last --
----------

461
gcc/ada/sem_ch9.adb
View File

@ -27,7 +27,6 @@ with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
@ -140,14 +139,6 @@ package body Sem_Ch9 is
pragma Assert
(Nkind (N) in N_Protected_Type_Declaration | N_Protected_Body);
-- The lock-free implementation is currently enabled through a debug
-- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
-- lock-free implementation. In that case, the debug flag is not needed.
if not Lock_Free_Given and then not Debug_Flag_9 then
return False;
end if;
-- Get the number of errors detected by the compiler so far
if Lock_Free_Given then
@ -215,6 +206,27 @@ package body Sem_Ch9 is
Next (Par);
end loop;
end;
elsif Nkind (Decl) = N_Subprogram_Declaration
and then
Nkind (Specification (Decl)) = N_Function_Specification
and then
Nkind (Result_Definition (Specification (Decl)))
in N_Has_Entity
and then
Needs_Secondary_Stack
(Entity (Result_Definition (Specification (Decl))))
then
if Lock_Free_Given then
-- Message text is imprecise; "unconstrained" is
-- similar to "needs secondary stack" but not identical.
Error_Msg_N
("unconstrained function result subtype not allowed "
& "when Lock_Free given",
Decl);
else
return False;
end if;
end if;
-- Examine private declarations after visible declarations
@ -254,11 +266,6 @@ package body Sem_Ch9 is
function Satisfies_Lock_Free_Requirements
(Sub_Body : Node_Id) return Boolean
is
Is_Procedure : constant Boolean :=
Ekind (Corresponding_Spec (Sub_Body)) =
E_Procedure;
-- Indicates if Sub_Body is a procedure body
Comp : Entity_Id := Empty;
-- Track the current component which the body references
@ -338,222 +345,220 @@ package body Sem_Ch9 is
-- Start of processing for Check_Node
begin
if Is_Procedure then
-- Allocators restricted
-- Allocators restricted
if Kind = N_Allocator then
if Lock_Free_Given then
Error_Msg_N ("allocator not allowed", N);
return Skip;
end if;
return Abandon;
-- Aspects Address, Export and Import restricted
elsif Kind = N_Aspect_Specification then
declare
Asp_Name : constant Name_Id :=
Chars (Identifier (N));
Asp_Id : constant Aspect_Id :=
Get_Aspect_Id (Asp_Name);
begin
if Asp_Id = Aspect_Address or else
Asp_Id = Aspect_Export or else
Asp_Id = Aspect_Import
then
Error_Msg_Name_1 := Asp_Name;
if Lock_Free_Given then
Error_Msg_N ("aspect% not allowed", N);
return Skip;
end if;
return Abandon;
end if;
end;
-- Address attribute definition clause restricted
elsif Kind = N_Attribute_Definition_Clause
and then Get_Attribute_Id (Chars (N)) =
Attribute_Address
then
Error_Msg_Name_1 := Chars (N);
if Lock_Free_Given then
if From_Aspect_Specification (N) then
Error_Msg_N ("aspect% not allowed", N);
else
Error_Msg_N ("% clause not allowed", N);
end if;
return Skip;
end if;
return Abandon;
-- Non-static Attribute references that don't denote a
-- static function restricted.
elsif Kind = N_Attribute_Reference
and then not Is_OK_Static_Expression (N)
and then not Is_Static_Function (N)
then
if Lock_Free_Given then
Error_Msg_N
("non-static attribute reference not allowed", N);
return Skip;
end if;
return Abandon;
-- Delay statements restricted
elsif Kind in N_Delay_Statement then
if Lock_Free_Given then
Error_Msg_N ("delay not allowed", N);
return Skip;
end if;
return Abandon;
-- Dereferences of access values restricted
elsif Kind = N_Explicit_Dereference
or else (Kind = N_Selected_Component
and then Is_Access_Type (Etype (Prefix (N))))
then
if Lock_Free_Given then
Error_Msg_N
("dereference of access value not allowed", N);
return Skip;
end if;
return Abandon;
-- Non-static function calls restricted
elsif Kind = N_Function_Call
and then not Is_OK_Static_Expression (N)
then
if Lock_Free_Given then
Error_Msg_N
("non-static function call not allowed", N);
return Skip;
end if;
return Abandon;
-- Goto statements restricted
elsif Kind = N_Goto_Statement then
if Lock_Free_Given then
Error_Msg_N ("goto statement not allowed", N);
return Skip;
end if;
return Abandon;
-- References
elsif Kind = 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
if Lock_Free_Given then
Error_Msg_NE
("reference to global variable& not " &
"allowed", N, Id);
return Skip;
end if;
return Abandon;
end if;
end;
-- Loop statements restricted
elsif Kind = N_Loop_Statement then
if Lock_Free_Given then
Error_Msg_N ("loop not allowed", N);
return Skip;
end if;
return Abandon;
-- Pragmas Export and Import restricted
elsif Kind = N_Pragma then
declare
Prag_Name : constant Name_Id :=
Pragma_Name (N);
Prag_Id : constant Pragma_Id :=
Get_Pragma_Id (Prag_Name);
begin
if Prag_Id = Pragma_Export
or else Prag_Id = Pragma_Import
then
Error_Msg_Name_1 := Prag_Name;
if Lock_Free_Given then
if From_Aspect_Specification (N) then
Error_Msg_N ("aspect% not allowed", N);
else
Error_Msg_N ("pragma% not allowed", N);
end if;
return Skip;
end if;
return Abandon;
end if;
end;
-- Procedure call statements restricted
elsif Kind = N_Procedure_Call_Statement then
if Lock_Free_Given then
Error_Msg_N ("procedure call not allowed", N);
return Skip;
end if;
return Abandon;
-- Quantified expression restricted. Note that we have
-- to check the original node as well, since at this
-- stage, it may have been rewritten.
elsif Kind = N_Quantified_Expression
or else
Nkind (Original_Node (N)) = N_Quantified_Expression
then
if Lock_Free_Given then
Error_Msg_N
("quantified expression not allowed", N);
return Skip;
end if;
return Abandon;
if Kind = N_Allocator then
if Lock_Free_Given then
Error_Msg_N ("allocator not allowed", N);
return Skip;
end if;
return Abandon;
-- Aspects Address, Export and Import restricted
elsif Kind = N_Aspect_Specification then
declare
Asp_Name : constant Name_Id :=
Chars (Identifier (N));
Asp_Id : constant Aspect_Id :=
Get_Aspect_Id (Asp_Name);
begin
if Asp_Id = Aspect_Address or else
Asp_Id = Aspect_Export or else
Asp_Id = Aspect_Import
then
Error_Msg_Name_1 := Asp_Name;
if Lock_Free_Given then
Error_Msg_N ("aspect% not allowed", N);
return Skip;
end if;
return Abandon;
end if;
end;
-- Address attribute definition clause restricted
elsif Kind = N_Attribute_Definition_Clause
and then Get_Attribute_Id (Chars (N)) =
Attribute_Address
then
Error_Msg_Name_1 := Chars (N);
if Lock_Free_Given then
if From_Aspect_Specification (N) then
Error_Msg_N ("aspect% not allowed", N);
else
Error_Msg_N ("% clause not allowed", N);
end if;
return Skip;
end if;
return Abandon;
-- Non-static Attribute references that don't denote a
-- static function restricted.
elsif Kind = N_Attribute_Reference
and then not Is_OK_Static_Expression (N)
and then not Is_Static_Function (N)
then
if Lock_Free_Given then
Error_Msg_N
("non-static attribute reference not allowed", N);
return Skip;
end if;
return Abandon;
-- Delay statements restricted
elsif Kind in N_Delay_Statement then
if Lock_Free_Given then
Error_Msg_N ("delay not allowed", N);
return Skip;
end if;
return Abandon;
-- Dereferences of access values restricted
elsif Kind = N_Explicit_Dereference
or else (Kind = N_Selected_Component
and then Is_Access_Type (Etype (Prefix (N))))
then
if Lock_Free_Given then
Error_Msg_N
("dereference of access value not allowed", N);
return Skip;
end if;
return Abandon;
-- Non-static function calls restricted
elsif Kind = N_Function_Call
and then not Is_OK_Static_Expression (N)
then
if Lock_Free_Given then
Error_Msg_N
("non-static function call not allowed", N);
return Skip;
end if;
return Abandon;
-- Goto statements restricted
elsif Kind = N_Goto_Statement then
if Lock_Free_Given then
Error_Msg_N ("goto statement not allowed", N);
return Skip;
end if;
return Abandon;
-- References
elsif Kind = 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
if Lock_Free_Given then
Error_Msg_NE
("reference to global variable& not " &
"allowed", N, Id);
return Skip;
end if;
return Abandon;
end if;
end;
-- Loop statements restricted
elsif Kind = N_Loop_Statement then
if Lock_Free_Given then
Error_Msg_N ("loop not allowed", N);
return Skip;
end if;
return Abandon;
-- Pragmas Export and Import restricted
elsif Kind = N_Pragma then
declare
Prag_Name : constant Name_Id :=
Pragma_Name (N);
Prag_Id : constant Pragma_Id :=
Get_Pragma_Id (Prag_Name);
begin
if Prag_Id = Pragma_Export
or else Prag_Id = Pragma_Import
then
Error_Msg_Name_1 := Prag_Name;
if Lock_Free_Given then
if From_Aspect_Specification (N) then
Error_Msg_N ("aspect% not allowed", N);
else
Error_Msg_N ("pragma% not allowed", N);
end if;
return Skip;
end if;
return Abandon;
end if;
end;
-- Procedure call statements restricted
elsif Kind = N_Procedure_Call_Statement then
if Lock_Free_Given then
Error_Msg_N ("procedure call not allowed", N);
return Skip;
end if;
return Abandon;
-- Quantified expression restricted. Note that we have
-- to check the original node as well, since at this
-- stage, it may have been rewritten.
elsif Kind = N_Quantified_Expression
or else
Nkind (Original_Node (N)) = N_Quantified_Expression
then
if Lock_Free_Given then
Error_Msg_N
("quantified expression not allowed", N);
return Skip;
end if;
return Abandon;
end if;
-- A protected subprogram (function or procedure) may

3
gcc/ada/snames.adb-tmpl
View File

@ -256,8 +256,6 @@ package body Snames is
return Pragma_Interface;
when Name_Interrupt_Priority =>
return Pragma_Interrupt_Priority;
when Name_Lock_Free =>
return Pragma_Lock_Free;
when Name_Preelaborable_Initialization =>
return Pragma_Preelaborable_Initialization;
when Name_Priority =>
@ -489,7 +487,6 @@ package body Snames is
or else N = Name_Fast_Math
or else N = Name_Interface
or else N = Name_Interrupt_Priority
or else N = Name_Lock_Free
or else N = Name_Preelaborable_Initialization
or else N = Name_Priority
or else N = Name_Secondary_Stack_Size

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

@ -600,12 +600,7 @@ package Snames is
Name_Linker_Options : constant Name_Id := N + $;
Name_Linker_Section : constant Name_Id := N + $; -- GNAT
Name_List : constant Name_Id := N + $;
-- Note: Lock_Free is not in this list because its name matches the name of
-- the corresponding attribute. However, it is included in the definition
-- of the type Pragma_Id and the functions Get_Pragma_Id and Is_Pragma_Name
-- correctly recognize and process Lock_Free. Lock_Free is a GNAT pragma.
Name_Lock_Free : constant Name_Id := N + $; -- GNAT
Name_Loop_Invariant : constant Name_Id := N + $; -- GNAT
Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT
Name_Loop_Variant : constant Name_Id := N + $; -- GNAT
@ -978,7 +973,6 @@ package Snames is
Name_Leading_Part : constant Name_Id := N + $;
Name_Length : constant Name_Id := N + $;
Name_Library_Level : constant Name_Id := N + $; -- GNAT
Name_Lock_Free : constant Name_Id := N + $; -- GNAT
Name_Loop_Entry : constant Name_Id := N + $; -- GNAT
Name_Machine_Emax : constant Name_Id := N + $;
Name_Machine_Emin : constant Name_Id := N + $;
@ -1503,7 +1497,6 @@ package Snames is
Attribute_Leading_Part,
Attribute_Length,
Attribute_Library_Level,
Attribute_Lock_Free,
Attribute_Loop_Entry,
Attribute_Machine_Emax,
Attribute_Machine_Emin,
@ -1889,6 +1882,7 @@ package Snames is
Pragma_Linker_Options,
Pragma_Linker_Section,
Pragma_List,
Pragma_Lock_Free,
Pragma_Loop_Invariant,
Pragma_Loop_Optimize,
Pragma_Loop_Variant,
@ -1981,7 +1975,6 @@ package Snames is
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Interrupt_Priority,
Pragma_Lock_Free,
Pragma_Preelaborable_Initialization,
Pragma_Priority,
Pragma_Secondary_Stack_Size,
@ -2073,10 +2066,10 @@ package Snames is
function Is_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized pragma. Note
-- that pragmas CPU, Dispatching_Domain, Fast_Math, Interrupt_Priority,
-- Lock_Free, Priority, Storage_Size, and Storage_Unit are recognized
-- as pragmas by this function even though their names are separate from
-- the other pragma names. For this reason, clients should always use
-- this function, rather than do range tests on Name_Id values.
-- Priority, Storage_Size, and Storage_Unit are recognized as pragmas by
-- this function even though their names are separate from the other
-- pragma names. For this reason, clients should always use this function,
-- rather than do range tests on Name_Id values.
function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized configuration