The Concurrent_Readers_Locking policy is added.
This policy is needed to implement concurrent readers on PO
functions. this is a work in progress, more changes to enable this
capability will follow
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-09-27 Pascal Obry <o...@adacore.com>
* rtsfind.ads: Add RE_Lock_Read_Only into rtsfind circuitry.
(RE_Id): Add RE_Lock_Read_Only.
(RE_Unit_Table): Likewise.
* sem_prag.adb (Process_Convention): Change Pragma_Locking_Policy
to lift restriction on first character. Handle now the
Name_Concurrent_Readers_Locking where policy character is set to
'R'.
* snames.ads-tmpl (Name_Concurrent_Readers_Locking): New
constant.
* exp_ch9.adb (Build_Protected_Subprogram_Body): Generate a
read only lock for function in protected object.
* s-taprob.ads (Lock_Read_Only): Remove obsolete comment as
this routine is now used.
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 179247)
+++ exp_ch9.adb (working copy)
@@ -3243,6 +3243,7 @@
Stmts : List_Id;
Object_Parm : Node_Id;
Exc_Safe : Boolean;
+ Lock_Kind : RE_Id;
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
-- Tell whether a given subprogram cannot raise an exception
@@ -3389,12 +3390,16 @@
Parameter_Associations => Uactuals));
end if;
+ Lock_Kind := RE_Lock_Read_Only;
+
else
Unprot_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals);
+
+ Lock_Kind := RE_Lock;
end if;
-- Wrap call in block that will be covered by an at_end handler
@@ -3419,7 +3424,7 @@
Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
when System_Tasking_Protected_Objects =>
- Lock_Name := New_Reference_To (RTE (RE_Lock), Loc);
+ Lock_Name := New_Reference_To (RTE (Lock_Kind), Loc);
Service_Name := New_Reference_To (RTE (RE_Unlock), Loc);
when others =>
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 179247)
+++ gnat_rm.texi (working copy)
@@ -7916,8 +7916,9 @@
The implementation should use names that end with @samp{_Locking} for
locking policies defined by the implementation.
@end cartouche
-Followed. A single implementation-defined locking policy is defined,
-whose name (@code{Inheritance_Locking}) follows this suggestion.
+Followed. Two implementation-defined locking policies are defined,
+whose names (@code{Inheritance_Locking} and
+@code{Concurrent_Readers_Locking}) follow this suggestion.
@cindex Entry queuing policies
@unnumberedsec D.4(16): Entry Queuing Policies
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 179247)
+++ rtsfind.ads (working copy)
@@ -1653,6 +1653,7 @@
RE_Initialize_Protection, -- System.Tasking.Protected_Objects
RE_Finalize_Protection, -- System.Tasking.Protected_Objects
RE_Lock, -- System.Tasking.Protected_Objects
+ RE_Lock_Read_Only, -- System.Tasking.Protected_Objects
RE_Get_Ceiling, -- System.Tasking.Protected_Objects
RE_Set_Ceiling, -- System.Tasking.Protected_Objects
RE_Unlock, -- System.Tasking.Protected_Objects
@@ -2883,6 +2884,7 @@
RE_Initialize_Protection => System_Tasking_Protected_Objects,
RE_Finalize_Protection => System_Tasking_Protected_Objects,
RE_Lock => System_Tasking_Protected_Objects,
+ RE_Lock_Read_Only => System_Tasking_Protected_Objects,
RE_Get_Ceiling => System_Tasking_Protected_Objects,
RE_Set_Ceiling => System_Tasking_Protected_Objects,
RE_Unlock => System_Tasking_Protected_Objects,
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 179247)
+++ sem_prag.adb (working copy)
@@ -10834,17 +10834,24 @@
-- pragma Locking_Policy (policy_IDENTIFIER);
when Pragma_Locking_Policy => declare
- LP : Character;
-
+ subtype LP_Range is Name_Id
+ range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
+ LP_Val : LP_Range;
+ LP : Character;
begin
Check_Ada_83_Warning;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Locking_Policy (Arg1);
Check_Valid_Configuration_Pragma;
- Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
- LP := Fold_Upper (Name_Buffer (1));
+ LP_Val := Chars (Get_Pragma_Arg (Arg1));
+ case LP_Val is
+ when Name_Ceiling_Locking => LP := 'C';
+ when Name_Inheritance_Locking => LP := 'I';
+ when Name_Concurrent_Readers_Locking => LP := 'R';
+ end case;
+
if Locking_Policy /= ' '
and then Locking_Policy /= LP
then
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 179247)
+++ snames.ads-tmpl (working copy)
@@ -909,13 +909,10 @@
-- Names of recognized locking policy identifiers
- -- Note: policies are identified by the first character of the
- -- name (e.g. C for Ceiling_Locking). If new policy names are added,
- -- the first character must be distinct.
-
First_Locking_Policy_Name : constant Name_Id := N + $;
Name_Ceiling_Locking : constant Name_Id := N + $;
Name_Inheritance_Locking : constant Name_Id := N + $;
+ Name_Concurrent_Readers_Locking : constant Name_Id := N + $; -- GNAT
Last_Locking_Policy_Name : constant Name_Id := N + $;
-- Names of recognized queuing policy identifiers
@@ -1500,7 +1497,8 @@
type Locking_Policy_Id is (
Locking_Policy_Inheritance_Locking,
- Locking_Policy_Ceiling_Locking);
+ Locking_Policy_Ceiling_Locking,
+ Locking_Policy_Concurrent_Readers_Locking);
---------------------------
-- Pragma ID Definitions --
Index: s-taprob.ads
===================================================================
--- s-taprob.ads (revision 179247)
+++ s-taprob.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -193,10 +193,6 @@
-- has been made by the caller. Other calls to Lock_Read_Only may (but
-- need not) return before the call to Unlock, and the corresponding
-- callers will also own the lock for read access.
- --
- -- Note: we are not currently using this interface, it is provided
- -- for possible future use. At the current time, everyone uses Lock
- -- for both read and write locks.
procedure Set_Ceiling
(Object : Protection_Access;
