Patchwork [Ada] New restrictions for the lock-free implementation of protected objects

login
register
mail settings
Submitter Arnaud Charlet
Date July 23, 2012, 8:29 a.m.
Message ID <20120723082947.GA18911@adacore.com>
Download mbox | patch
Permalink /patch/172580/
State New
Headers show

Comments

Arnaud Charlet - July 23, 2012, 8:29 a.m.
This patch updates the restrictions of the lock-free implementation.
Furthermore, it also catches every error messages issued by the routine
Allows_Lock_Free_Implementation.

The test below illustrates some of the new restrictions:

------------
-- Source --
------------

package Typ is
   protected Prot with Lock_Free is
      procedure Test;
   private
      Count : Integer := 0;
      L     : Integer := 0;
   end Prot;
end Typ;

package body Typ is
   protected body Prot is
      procedure Test is
         type Rec is record
            I, J : Integer;
         end record;

         type Rec_Access is access Rec;
         IA : Rec_Access := new Rec'(1,2);

      begin
         delay 3.0;

         if Count = 0 then
            goto Continue;
         end if;

         loop
            Count := Count + IA.J;
            exit when Count = 10;
         end loop;

         <<Continue>>

         L := Count + 1;
      end Test;
   end Prot;
end Typ;

-------------------------------
-- Compilation and Execution --
-------------------------------

$ gnatmake -q -gnat12 -gnatws typ.adb
typ.adb:3:07: body not allowed when Lock_Free given
typ.adb:9:29: allocator not allowed
typ.adb:12:10: procedure call not allowed
typ.adb:15:13: goto statement not allowed
typ.adb:18:10: loop not allowed
typ.adb:25:10: only one protected component allowed
gnatmake: "typ.adb" compilation error

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-07-23  Vincent Pucci  <pucci@adacore.com>

	* sem_ch9.adb (Allows_Lock_Free_Implementation): Flag
	Lock_Free_Given renames previous flag Complain. Description
	updated. Henceforth, catch every error messages issued by this
	routine when Lock_Free_Given is True.  Declaration restriction
	updated: No non-elementary parameter instead (even in parameter)
	New subprogram body restrictions implemented: No allocator,
	no address, import or export rep items, no delay statement,
	no goto statement, no quantified expression and no dereference
	of access value.

Patch

Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb	(revision 189773)
+++ exp_ch9.adb	(working copy)
@@ -3188,7 +3188,7 @@ 
 
                   Rewrite (Stmt,
                     Make_Implicit_If_Statement (N,
-                      Condition =>
+                      Condition       =>
                         Make_Function_Call (Loc,
                           Name                   =>
                             New_Reference_To (Try_Write, Loc),
@@ -3379,9 +3379,9 @@ 
               Make_Object_Renaming_Declaration (Loc,
                 Defining_Identifier =>
                   Defining_Identifier (Comp_Decl),
-                Subtype_Mark      =>
+                Subtype_Mark        =>
                   New_Occurrence_Of (Comp_Type, Loc),
-                Name              =>
+                Name                =>
                   New_Reference_To (Desired_Comp, Loc)));
 
             --  Wrap any return or raise statements in Stmts in same the manner
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb	(revision 189768)
+++ sem_ch9.adb	(working copy)
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Debug;    use Debug;
@@ -68,24 +69,30 @@ 
 
    function Allows_Lock_Free_Implementation
      (N        : Node_Id;
-      Complain : Boolean := False) return Boolean;
+      Lock_Free_Given : Boolean := False) return Boolean;
    --  This routine returns True iff 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
+   --         Protected subprogram declarations may not have non-elementary
+   --           parameters.
    --
    --    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-elementary out parameters
-   --            May not contain loop statements or procedure calls
+   --            May not contain address representation items, allocators and
+   --              quantified expressions.
+   --            May not contain delay, goto, loop and procedure call
+   --              statements.
+   --            May not contain exported and imported entities
+   --            May not dereference access values
    --            Function calls and attribute references must be static
    --
-   --  If Complain is True, an error message is issued when False is returned
+   --  If Lock_Free_Given is True, an error message is issued when False is
+   --  returned.
 
    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
    --  Given either a protected definition or a task definition in D, check
@@ -115,22 +122,32 @@ 
    -------------------------------------
 
    function Allows_Lock_Free_Implementation
-     (N        : Node_Id;
-      Complain : Boolean := False) return Boolean
+     (N               : Node_Id;
+      Lock_Free_Given : Boolean := False) return Boolean
    is
+      Errors_Count : Nat;
+      --  Errors_Count is a count of errors detected by the compiler so far
+      --  when Lock_Free_Given is True.
+
    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.
+      --  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 Complain and then not Debug_Flag_9 then
+      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
+         Errors_Count := Serious_Errors_Detected;
+      end if;
+
       --  Protected type declaration case
 
       if Nkind (N) = N_Protected_Type_Declaration then
@@ -150,14 +167,14 @@ 
                --  restrictions.
 
                if Nkind (Decl) = N_Entry_Declaration then
-                  if Complain then
+                  if Lock_Free_Given then
                      Error_Msg_N
                        ("entry not allowed when Lock_Free given", Decl);
+                  else
+                     return False;
                   end if;
 
-                  return False;
-
-               --  Non-elementary out parameters in protected procedure are not
+               --  Non-elementary parameters in protected procedure are not
                --  allowed by the lock-free restrictions.
 
                elsif Nkind (Decl) = N_Subprogram_Declaration
@@ -176,18 +193,17 @@ 
                   begin
                      Par := First (Par_Specs);
                      while Present (Par) loop
-                        if Out_Present (Par)
-                          and then not Is_Elementary_Type
-                                         (Etype (Parameter_Type (Par)))
+                        if not Is_Elementary_Type
+                                 (Etype (Defining_Identifier (Par)))
                         then
-                           if Complain then
+                           if Lock_Free_Given then
                               Error_Msg_NE
-                                ("non-elementary out parameter& not allowed "
+                                ("non-elementary parameter& not allowed "
                                  & "when Lock_Free given",
                                  Par, Defining_Identifier (Par));
+                           else
+                              return False;
                            end if;
-
-                           return False;
                         end if;
 
                         Next (Par);
@@ -240,6 +256,10 @@ 
                Comp : Entity_Id := Empty;
                --  Track the current component which the body references
 
+               Errors_Count : Nat;
+               --  Errors_Count is a count of errors detected by the compiler
+               --  so far when Lock_Free_Given is True.
+
                function Check_Node (N : Node_Id) return Traverse_Result;
                --  Check that node N meets the lock free restrictions
 
@@ -248,6 +268,7 @@ 
                ----------------
 
                function Check_Node (N : Node_Id) return Traverse_Result is
+                  Kind : constant Node_Kind := Nkind (N);
 
                   --  The following function belongs in sem_eval ???
 
@@ -310,51 +331,123 @@ 
 
                begin
                   if Is_Procedure then
-                     --  Attribute references must be static or denote a static
-                     --  function.
+                     --  Allocators restricted
 
-                     if Nkind (N) = N_Attribute_Reference
+                     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_Static_Expression (N)
                        and then not Is_Static_Function (N)
                      then
-                        if Complain then
+                        if Lock_Free_Given then
                            Error_Msg_N
                              ("non-static attribute reference not allowed", N);
+                           return Skip;
                         end if;
 
                         return Abandon;
 
-                     --  Function calls must be static
+                     --  Delay statements restricted
 
-                     elsif Nkind (N) = N_Function_Call
+                     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;
+
+                     --  Explicit dereferences restricted (i.e. dereferences of
+                     --  access values).
+
+                     elsif Kind = N_Explicit_Dereference then
+                        if Lock_Free_Given then
+                           Error_Msg_N ("explicit dereference not allowed", N);
+                           return Skip;
+                        end if;
+
+                        return Abandon;
+
+                     --  Non-static function calls restricted
+
+                     elsif Kind = N_Function_Call
                        and then not Is_Static_Expression (N)
                      then
-                        if Complain then
+                        if Lock_Free_Given then
                            Error_Msg_N ("non-static function call not allowed",
                                         N);
+                           return Skip;
                         end if;
 
                         return Abandon;
 
-                     --  Loop statements and procedure calls are prohibited
+                     --  Goto statements restricted
 
-                     elsif Nkind (N) = N_Loop_Statement then
-                        if Complain then
-                           Error_Msg_N ("loop not allowed", N);
+                     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;
 
-                     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
+                     elsif Kind = N_Identifier
                        and then Present (Entity (N))
                      then
                         declare
@@ -372,15 +465,75 @@ 
                              and then not Scope_Within_Or_Same (Scope (Id),
                                             Protected_Body_Subprogram (Sub_Id))
                            then
-                              if Complain 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
+
+                     elsif Kind = 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;
                   end if;
 
@@ -388,7 +541,7 @@ 
                   --  reference only one component of the protected type, plus
                   --  the type of the component must support atomic operation.
 
-                  if Nkind (N) = N_Identifier
+                  if Kind = N_Identifier
                     and then Present (Entity (N))
                   then
                      declare
@@ -441,11 +594,12 @@ 
                                  when 8 | 16 | 32 | 64 =>
                                     null;
                                  when others           =>
-                                    if Complain then
+                                    if Lock_Free_Given then
                                        Error_Msg_NE
                                          ("type of& must support atomic " &
                                           "operations",
                                           N, Comp_Id);
+                                       return Skip;
                                     end if;
 
                                     return Abandon;
@@ -458,10 +612,11 @@ 
                                  Comp := Comp_Id;
 
                               elsif Comp /= Comp_Id then
-                                 if Complain then
+                                 if Lock_Free_Given then
                                     Error_Msg_N
                                       ("only one protected component allowed",
                                        N);
+                                    return Skip;
                                  end if;
 
                                  return Abandon;
@@ -479,8 +634,17 @@ 
             --  Start of processing for Satisfies_Lock_Free_Requirements
 
             begin
-               if Check_All_Nodes (Sub_Body) = OK then
+               --  Get the number of errors detected by the compiler so far
 
+               if Lock_Free_Given then
+                  Errors_Count := Serious_Errors_Detected;
+               end if;
+
+               if Check_All_Nodes (Sub_Body) = OK
+                 and then (not Lock_Free_Given
+                            or else Errors_Count = Serious_Errors_Detected)
+               then
+
                   --  Establish a relation between the subprogram body and the
                   --  unique protected component it references.
 
@@ -503,12 +667,12 @@ 
                if Nkind (Decl) = N_Subprogram_Body
                  and then not Satisfies_Lock_Free_Requirements (Decl)
                then
-                  if Complain then
+                  if Lock_Free_Given then
                      Error_Msg_N
-                       ("body not allowed when Lock_Free given", Decl);
+                       ("illegal body when Lock_Free given", Decl);
+                  else
+                     return False;
                   end if;
-
-                  return False;
                end if;
 
                Next (Decl);
@@ -516,6 +680,15 @@ 
          end Protected_Body_Case;
       end if;
 
+      --  When Lock_Free is given, check if no error has been detected during
+      --  the process.
+
+      if Lock_Free_Given
+        and then Errors_Count /= Serious_Errors_Detected
+      then
+         return False;
+      end if;
+
       return True;
    end Allows_Lock_Free_Implementation;
 
@@ -1611,7 +1784,7 @@ 
       --  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
+         if not Allows_Lock_Free_Implementation (N, True) then
             return;
          end if;
 
@@ -1886,7 +2059,7 @@ 
             end if;
          end;
 
-         if not Allows_Lock_Free_Implementation (N, Complain => True) then
+         if not Allows_Lock_Free_Implementation (N, True) then
             return;
          end if;
       end if;