Patchwork [Ada] Attribute and pragma for lock-free implementation

login
register
mail settings
Submitter Arnaud Charlet
Date June 14, 2012, 10:50 a.m.
Message ID <20120614105016.GA18369@adacore.com>
Download mbox | patch
Permalink /patch/164909/
State New
Headers show

Comments

Arnaud Charlet - June 14, 2012, 10:50 a.m.
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  <pucci@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.

Patch

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