This patch implements a Lock_Free pragma for Ada2005 usage and a Lock_Free
attribute for user query.
The test provided below illustrates the usage of both Lock_Free pragma and
attribute.
-------------
-- Source --
-------------
with Text_IO; use Text_IO;
procedure Main is
protected type Counter is
pragma Lock_Free;
procedure Increment;
private
Count : Natural := 0;
end Counter;
protected body Counter is
procedure Increment is
begin
Count := Count + 1;
end Increment;
end Counter;
C : Counter;
begin
if C'Lock_Free then
Put_Line ("Lock_Free : ON");
else
Put_Line ("Lock_Free : OFF");
end if;
end Main;
-------------------------------
-- Compilation and Execution --
-------------------------------
gnatmake -q main.adb
$./main
------------
-- Output --
------------
$Lock_Free : ON
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-06-14 Vincent Pucci <pu...@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference): Lock_Free
attribute case added.
* par-prag.adb (Prag): Lock_Free pragma case added.
* sem_attr.adb (Analyze_Attribute_Reference): Lock_Free attribute
case added.
* sem_ch13.adb (Analyze_Aspect_Specifications): Record_Rep_Item
call added for Aspect_Lock_Free.
* sem_ch9.adb (Allows_Lock_Free_Implementation): New Lock_Free
error messages for subprogram bodies.
(Lock_Free_Disabled): New routine.
(Analyze_Protected_Body): Call to Lock_Free_Disabled added.
* sem_prag.adb (Analyze_Pragma): Lock_Free pragma case added.
* snames.adb-tmpl (Get_Pragma_Id): Name_Lock_Free case added.
(Is_Pragma_Name): Name_Lock_Free case added.
* snames.ads-tmpl: Attribute_Lock_Free and Pragma_Lock_Free added.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 188605)
+++ exp_attr.adb (working copy)
@@ -3065,6 +3065,29 @@
end if;
end;
+ ---------------
+ -- Lock_Free --
+ ---------------
+
+ -- Rewrite the attribute reference with the value of Uses_Lock_Free
+
+ when Attribute_Lock_Free => Lock_Free : declare
+ Val : Entity_Id;
+
+ begin
+ if Uses_Lock_Free (Ptyp) then
+ Val := Standard_True;
+
+ else
+ Val := Standard_False;
+ end if;
+
+ Rewrite (N,
+ New_Occurrence_Of (Val, Loc));
+
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end Lock_Free;
+
-------------
-- Machine --
-------------
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb (revision 188605)
+++ sem_ch9.adb (working copy)
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -263,18 +262,43 @@
begin
-- Function calls and attribute references must be static
- if Nkind_In (N, N_Attribute_Reference, N_Function_Call)
+ if Nkind (N) = N_Attribute_Reference
and then not Is_Static_Expression (N)
then
+ if Complain then
+ Error_Msg_N
+ ("non-static attribute reference not allowed",
+ N);
+ end if;
+
return Abandon;
+ elsif Nkind (N) = N_Function_Call
+ and then not Is_Static_Expression (N)
+ then
+ if Complain then
+ Error_Msg_N ("non-static function call not allowed",
+ N);
+ end if;
+
+ return Abandon;
+
-- Loop statements and procedure calls are prohibited
- elsif Nkind_In (N, N_Loop_Statement,
- N_Procedure_Call_Statement)
- then
+ elsif Nkind (N) = N_Loop_Statement then
+ if Complain then
+ Error_Msg_N ("loop not allowed", N);
+ end if;
+
return Abandon;
+ elsif Nkind (N) = N_Procedure_Call_Statement then
+ if Complain then
+ Error_Msg_N ("procedure call not allowed", N);
+ end if;
+
+ return Abandon;
+
-- References
elsif Nkind (N) = N_Identifier
@@ -295,6 +319,12 @@
and then not Scope_Within_Or_Same (Scope (Id),
Protected_Body_Subprogram (Sub_Id))
then
+ if Complain then
+ Error_Msg_NE
+ ("reference to global variable& not allowed",
+ N, Id);
+ end if;
+
return Abandon;
-- Prohibit non-scalar out parameters (scalar
@@ -305,6 +335,12 @@
and then not Is_Elementary_Type (Etype (Id))
and then Scope_Within_Or_Same (Scope (Id), Sub_Id)
then
+ if Complain then
+ Error_Msg_NE
+ ("non-elementary out parameter& not allowed",
+ N, Id);
+ end if;
+
return Abandon;
-- A protected subprogram may reference only one
@@ -327,6 +363,13 @@
-- body.
elsif Comp /= Id then
+ if Complain then
+ Error_Msg_N
+ ("only one protected component " &
+ "allowed",
+ N);
+ end if;
+
return Abandon;
end if;
end if;
@@ -352,6 +395,13 @@
-- body.
elsif Comp /= Prival_Link (Id) then
+ if Complain then
+ Error_Msg_N
+ ("only one protected component " &
+ "allowed",
+ N);
+ end if;
+
return Abandon;
end if;
end if;
@@ -1375,7 +1425,6 @@
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;
@@ -1390,6 +1439,50 @@
-- differs from Spec_Id in the case of a single protected object, since
-- Spec_Id is set to the protected type in this case).
+ function Lock_Free_Disabled return Boolean;
+ -- This routine returns False if the protected object has a Lock_Free
+ -- aspect specification or a Lock_Free pragma that turns off the
+ -- lock-free implementation (e.g. whose expression is False).
+
+ ------------------------
+ -- Lock_Free_Disabled --
+ ------------------------
+
+ function Lock_Free_Disabled return Boolean is
+ Ritem : constant Node_Id :=
+ Get_Rep_Item
+ (Spec_Id, Name_Lock_Free, Check_Parents => False);
+
+ begin
+ if Present (Ritem) then
+ -- Pragma with one argument
+
+ if Nkind (Ritem) = N_Pragma
+ and then Present (Pragma_Argument_Associations (Ritem))
+ then
+ return
+ Is_False (Static_Boolean
+ (Expression (First (Pragma_Argument_Associations (Ritem)))));
+
+ -- Aspect Specification with expression present
+
+ elsif Nkind (Ritem) = N_Aspect_Specification
+ and then Present (Expression (Ritem))
+ then
+ return Is_False (Static_Boolean (Expression (Ritem)));
+
+ -- Otherwise, return False
+
+ else
+ return False;
+ end if;
+ end if;
+
+ return False;
+ end Lock_Free_Disabled;
+
+ -- Start of processing for Analyze_Protected_Body
+
begin
Tasking_Used := True;
Set_Ekind (Body_Id, E_Protected_Body);
@@ -1450,37 +1543,21 @@
Process_End_Label (N, 't', Ref_Id);
End_Scope;
- -- Turn on/off the lock-free implementation for the protected object
+ -- When a Lock_Free aspect specification/pragma forces the lock-free
+ -- implementation, verify the protected body meets all the restrictions,
+ -- otherwise Allows_Lock_Free_Implementation issues an error message.
- -- 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.
+ -- In other cases, if there is no aspect specification/pragma that
+ -- disables the lock-free implementation, check both the protected
+ -- declaration and body satisfy the lock-free restrictions.
- elsif Allows_Lock_Free_Implementation (Parent (Spec_Id))
+ elsif not Lock_Free_Disabled
+ and then Allows_Lock_Free_Implementation (Parent (Spec_Id))
and then Allows_Lock_Free_Implementation (N)
then
Set_Uses_Lock_Free (Spec_Id);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 188607)
+++ sem_prag.adb (working copy)
@@ -11118,6 +11118,54 @@
when Pragma_List =>
null;
+ ---------------
+ -- Lock_Free --
+ ---------------
+
+ -- pragma Lock_Free [(Boolean_EXPRESSION)];
+
+ when Pragma_Lock_Free => Lock_Free : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+ Ent : Entity_Id;
+ Val : Boolean;
+
+ begin
+ Check_No_Identifiers;
+ Check_At_Most_N_Arguments (1);
+
+ -- Protected definition case
+
+ if Nkind (P) = N_Protected_Definition then
+ Ent := Defining_Identifier (Parent (P));
+
+ -- One argument
+
+ if Arg_Count = 1 then
+ Arg := Get_Pragma_Arg (Arg1);
+ Val := Is_True (Static_Boolean (Arg));
+
+ -- Zero argument. In this case the expression is considered to
+ -- be True.
+
+ else
+ Val := True;
+ end if;
+
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
+
+ Check_Duplicate_Pragma (Ent);
+ Record_Rep_Item (Ent, N);
+ Set_Uses_Lock_Free (Ent, Val);
+
+ -- Anything else is incorrect
+
+ else
+ Pragma_Misplaced;
+ end if;
+ end Lock_Free;
+
--------------------
-- Locking_Policy --
--------------------
@@ -15212,6 +15260,7 @@
Pragma_Linker_Options => -1,
Pragma_Linker_Section => -1,
Pragma_List => -1,
+ Pragma_Lock_Free => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Machine_Attribute => -1,
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 188605)
+++ sem_attr.adb (working copy)
@@ -3569,6 +3569,19 @@
Check_Array_Type;
Set_Etype (N, Universal_Integer);
+ ---------------
+ -- 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;
+
-------------
-- Machine --
-------------
@@ -6767,6 +6780,15 @@
True);
end if;
+ ---------------
+ -- Lock_Free --
+ ---------------
+
+ -- Lock_Free attribute is a Boolean, thus no need to fold here.
+
+ when Attribute_Lock_Free =>
+ null;
+
----------
-- Last --
----------
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 188605)
+++ par-prag.adb (working copy)
@@ -1183,6 +1183,7 @@
Pragma_Linker_Destructor |
Pragma_Linker_Options |
Pragma_Linker_Section |
+ Pragma_Lock_Free |
Pragma_Locking_Policy |
Pragma_Long_Float |
Pragma_Machine_Attribute |
Index: snames.adb-tmpl
===================================================================
--- snames.adb-tmpl (revision 188605)
+++ snames.adb-tmpl (working copy)
@@ -219,6 +219,8 @@
return Pragma_Interface;
elsif N = Name_Interrupt_Priority then
return Pragma_Interrupt_Priority;
+ elsif N = Name_Lock_Free then
+ return Pragma_Lock_Free;
elsif N = Name_Priority then
return Pragma_Priority;
elsif N = Name_Relative_Deadline then
@@ -421,6 +423,7 @@
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_Relative_Deadline
or else N = Name_Priority
or else N = Name_Storage_Size
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 188607)
+++ sem_ch13.adb (working copy)
@@ -1445,6 +1445,8 @@
then
Set_Uses_Lock_Free (E);
end if;
+
+ Record_Rep_Item (E, Aspect);
end if;
goto Continue;
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 188605)
+++ snames.ads-tmpl (working copy)
@@ -142,7 +142,6 @@
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 + $;
@@ -522,6 +521,12 @@
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_Id
+ -- correctly recognize and process Lock_Free. Lock_Free is a GNAT pragma.
+
Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT
Name_Main : constant Name_Id := N + $; -- GNAT
Name_Main_Storage : constant Name_Id := N + $; -- GNAT
@@ -810,6 +815,7 @@
Name_Last_Valid : constant Name_Id := N + $; -- Ada 12
Name_Leading_Part : constant Name_Id := N + $;
Name_Length : constant Name_Id := N + $;
+ Name_Lock_Free : constant Name_Id := N + $; -- GNAT
Name_Machine_Emax : constant Name_Id := N + $;
Name_Machine_Emin : constant Name_Id := N + $;
Name_Machine_Mantissa : constant Name_Id := N + $;
@@ -1388,6 +1394,7 @@
Attribute_Last_Valid,
Attribute_Leading_Part,
Attribute_Length,
+ Attribute_Lock_Free,
Attribute_Machine_Emax,
Attribute_Machine_Emin,
Attribute_Machine_Mantissa,
@@ -1774,6 +1781,7 @@
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Interrupt_Priority,
+ Pragma_Lock_Free,
Pragma_Priority,
Pragma_Storage_Size,
Pragma_Storage_Unit,
@@ -1853,8 +1861,8 @@
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 AST_Entry, CPU, Dispatching_Domain, Fast_Math,
- -- Interrupt_Priority, Priority, Storage_Size, and Storage_Unit are
- -- recognized as pragmas by this function even though their names are
+ -- 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.
@@ -1895,8 +1903,9 @@
-- if N is not a name of a known (Ada defined or GNAT-specific) pragma.
-- Note that the function also works correctly for names of pragmas that
-- are not included in the main list of pragma Names (AST_Entry, CPU,
- -- Dispatching_Domain, Interrupt_Priority, Priority, Storage_Size, and
- -- Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
+ -- Dispatching_Domain, Interrupt_Priority, Lock_Free, Priority,
+ -- Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns
+ -- Pragma_Storage_Size).
function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
-- Returns Id of queuing policy corresponding to given name. It is an error
