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