s-taprop.ads (Initialize_Lock): New spec for r/w lock.

2011-09-27  Pascal Obry  <obry@adacore.com>

	* s-taprop.ads (Initialize_Lock)[RW_Lock]: New spec for r/w lock.
	(Finalize_Lock)[RW_Lock]: Likewise.
	(Write_Lock)[RW_Lock]: Likewise.
	(Unlock)[RW_Lock]: Likewise.
	(Read_Lock): Define L as RW_Lock (instead of Lock).
	* s-taprop-linux.adb (Initialize_Lock)[RW_Lock]: New
	routine for r/w lock.
	(Finalize_Lock)[RW_Lock]: Likewise.
	(Write_Lock)[RW_Lock]: Likewise.
	(Unlock)[RW_Lock]: Likewise.
	(Read_Lock): Define L as RW_Lock (instead of Lock).

	* s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
	s-taprop-mingw.adb, s-taprop-solaris.adb, s-taprop-irix.adb,
	s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-posix.adb
	(Initialize_Lock)[RW_Lock]: Same implementation as corresponding
	routine for standard lock.
	(Finalize_Lock)[RW_Lock]: Likewise.
	(Write_Lock)[RW_Lock]: Likewise.
	(Unlock)[RW_Lock]: Likewise.
	(Read_Lock): Define L as RW_Lock (instead of Lock).
	* s-taprob.ads, s-tpoben.ads (Protection): Add RWL (RW_Lock)
	in the record definition.
	* s-taprob.adb, s-taproben.adb (Finalize_Protection): Use r/w
	lock for 'R' locking policy.
	(Initialize_Protection): Likewise.
	(Lock): Likewise.
	(Lock_Read_Only): Likewise.
	(Unlock): Likewise.
	* s-taspri-posix.ads (RW_Lock): New type defined as
	OS_Interface.pthread_rwlock_t.

	* s-taspri-vxworks.ads, s-taspri-posix-noaltstack.ads,
	s-taspri-mingw.ads, s-taspri-solaris.ads, s-taspri-dummy.ads,
	s-taspri-posix.ads, s-taspri-vms.ads, s-taspri-hpux-dce.ads,
	s-taspri-tru64.ads (RW_Lock): New type defined as alias to Lock.

From-SVN: r179251

gcc/ada/ChangeLog

 2011-09-27  Pascal Obry  <obry@adacore.com>
 
+	* s-taprop.ads (Initialize_Lock)[RW_Lock]: New spec for r/w lock.
+	(Finalize_Lock)[RW_Lock]: Likewise.
+	(Write_Lock)[RW_Lock]: Likewise.
+	(Unlock)[RW_Lock]: Likewise.
+	(Read_Lock): Define L as RW_Lock (instead of Lock).
+	* s-taprop-linux.adb (Initialize_Lock)[RW_Lock]: New
+	routine for r/w lock.
+	(Finalize_Lock)[RW_Lock]: Likewise.
+	(Write_Lock)[RW_Lock]: Likewise.
+	(Unlock)[RW_Lock]: Likewise.
+	(Read_Lock): Define L as RW_Lock (instead of Lock).
+
+	* s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
+	s-taprop-mingw.adb, s-taprop-solaris.adb, s-taprop-irix.adb,
+	s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-posix.adb
+	(Initialize_Lock)[RW_Lock]: Same implementation as corresponding
+	routine for standard lock.
+	(Finalize_Lock)[RW_Lock]: Likewise.
+	(Write_Lock)[RW_Lock]: Likewise.
+	(Unlock)[RW_Lock]: Likewise.
+	(Read_Lock): Define L as RW_Lock (instead of Lock).
+	* s-taprob.ads, s-tpoben.ads (Protection): Add RWL (RW_Lock)
+	in the record definition.
+	* s-taprob.adb, s-taproben.adb (Finalize_Protection): Use r/w
+	lock for 'R' locking policy.
+	(Initialize_Protection): Likewise.
+	(Lock): Likewise.
+	(Lock_Read_Only): Likewise.
+	(Unlock): Likewise.
+	* s-taspri-posix.ads (RW_Lock): New type defined as
+	OS_Interface.pthread_rwlock_t.
+
+	* s-taspri-vxworks.ads, s-taspri-posix-noaltstack.ads,
+	s-taspri-mingw.ads, s-taspri-solaris.ads, s-taspri-dummy.ads,
+	s-taspri-posix.ads, s-taspri-vms.ads, s-taspri-hpux-dce.ads,
+	s-taspri-tru64.ads (RW_Lock): New type defined as alias to Lock.
+
+2011-09-27  Pascal Obry  <obry@adacore.com>
+
 	* exp_ch9.adb, s-taspri-posix.ads: Minor reformatting.
 
 2011-09-27  Pascal Obry  <obry@adacore.com>

gcc/ada/gnat_rm.texi

@@ -9896,11 +9896,15 @@ The policy is the same as that of the underlying threads implementation.
 in a pragma @code{Locking_Policy}.  See D.3(4).
 @end cartouche
 @noindent
-The only implementation defined policy permitted in GNAT is
-@code{Inheritance_Locking}.  On targets that support this policy, locking
-is implemented by inheritance, i.e.@: the task owning the lock operates
+The two implementation defined policies permitted in GNAT are
+@code{Inheritance_Locking} and  @code{Conccurent_Readers_Locking}.  On
+targets that support the @code{Inheritance_Locking} policy, locking is
+implemented by inheritance, i.e.@: the task owning the lock operates
 at a priority equal to the highest priority of any task currently
-requesting the lock.
+requesting the lock.  On targets that support the
+@code{Conccurent_Readers_Locking} policy, locking is implemented with a
+read/write lock allowing multiple propected object functions to enter
+concurrently.
 
 @sp 1
 @cartouche

gcc/ada/s-taprob.adb

@@ -7,7 +7,7 @@
 --                                  B o d y                                 --
 --                                                                          --
 --            Copyright (C) 1991-1994, Florida State University             --
---                     Copyright (C) 1995-2010, AdaCore                     --
+--                     Copyright (C) 1995-2011, AdaCore                     --
 --                                                                          --
 -- GNAT 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- --
@@ -57,7 +57,11 @@ package body System.Tasking.Protected_Objects is
 
    procedure Finalize_Protection (Object : in out Protection) is
    begin
+      if Locking_Policy = 'R' then
+         Finalize_Lock (Object.RWL'Unrestricted_Access);
+      else
          Finalize_Lock (Object.L'Unrestricted_Access);
+      end if;
    end Finalize_Protection;
 
    ---------------------------
@@ -75,7 +79,11 @@ package body System.Tasking.Protected_Objects is
          Init_Priority  := System.Priority'Last;
       end if;
 
+      if Locking_Policy = 'R' then
+         Initialize_Lock (Init_Priority, Object.RWL'Access);
+      else
          Initialize_Lock (Init_Priority, Object.L'Access);
+      end if;
       Object.Ceiling := System.Any_Priority (Init_Priority);
       Object.New_Ceiling := System.Any_Priority (Init_Priority);
       Object.Owner := Null_Task;
@@ -120,7 +128,11 @@ package body System.Tasking.Protected_Objects is
          raise Program_Error;
       end if;
 
+      if Locking_Policy = 'R' then
+         Write_Lock (Object.RWL'Access, Ceiling_Violation);
+      else
          Write_Lock (Object.L'Access, Ceiling_Violation);
+      end if;
 
       if Parameters.Runtime_Traces then
          Send_Trace_Info (PO_Lock);
@@ -177,7 +189,11 @@ package body System.Tasking.Protected_Objects is
          raise Program_Error;
       end if;
 
-      Read_Lock (Object.L'Access, Ceiling_Violation);
+      if Locking_Policy = 'R' then
+         Read_Lock (Object.RWL'Access, Ceiling_Violation);
+      else
+         Write_Lock (Object.L'Access, Ceiling_Violation);
+      end if;
 
       if Parameters.Runtime_Traces then
          Send_Trace_Info (PO_Lock);
@@ -263,7 +279,11 @@ package body System.Tasking.Protected_Objects is
          Object.Ceiling := Object.New_Ceiling;
       end if;
 
+      if Locking_Policy = 'R' then
+         Unlock (Object.RWL'Access);
+      else
          Unlock (Object.L'Access);
+      end if;
 
       if Parameters.Runtime_Traces then
          Send_Trace_Info (PO_Unlock);

gcc/ada/s-taprob.ads

@@ -212,6 +212,9 @@ private
       L : aliased Task_Primitives.Lock;
       --  Lock used to ensure mutual exclusive access to the protected object
 
+      RWL : aliased Task_Primitives.RW_Lock;
+      --  Lock used to support conccurent readers to the protected object
+
       Ceiling : System.Any_Priority;
       --  Ceiling priority associated to the protected object
 

gcc/ada/s-taprop-dummy.adb

@@ -158,6 +158,11 @@ package body System.Task_Primitives.Operations is
       null;
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      null;
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
    begin
       null;
@@ -218,6 +223,14 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+   begin
+      null;
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L : not null access RTS_Lock; Level : Lock_Level) is
    begin
       null;
@@ -264,7 +277,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L                 : not null access Lock;
+     (L                 : not null access RW_Lock;
       Ceiling_Violation : out Boolean)
    is
    begin
@@ -459,6 +472,11 @@ package body System.Task_Primitives.Operations is
       null;
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      null;
+   end Unlock;
+
    procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
@@ -502,6 +520,14 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L                 : not null access RW_Lock;
+      Ceiling_Violation : out Boolean)
+   is
+   begin
+      Ceiling_Violation := False;
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is

gcc/ada/s-taprop-hpux-dce.adb

@@ -254,6 +254,14 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+   begin
+      Initialize_Lock (Prio, Lock (L.all)'Unrestricted_Access);
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L     : not null access RTS_Lock;
       Level : Lock_Level)
    is
@@ -293,6 +301,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      Finalize_Lock (Lock (L.all)'Unrestricted_Access);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
       Result : Interfaces.C.int;
    begin
@@ -324,6 +337,14 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L                 : not null access RW_Lock;
+      Ceiling_Violation : out Boolean)
+   is
+   begin
+      Write_Lock (Lock (L.all)'Unrestricted_Access, Ceiling_Violation);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is
@@ -349,7 +370,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L                 : not null access Lock;
+     (L                 : not null access RW_Lock;
       Ceiling_Violation : out Boolean)
    is
    begin
@@ -367,6 +388,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      Unlock (Lock (L.all)'Unrestricted_Access);
+   end Unlock;
+
    procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)

gcc/ada/s-taprop-irix.adb

@@ -268,6 +268,14 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+   begin
+      Initialize_Lock (Prio, Lock (L.all)'Unrestricted_Access);
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L     : not null access RTS_Lock;
       Level : Lock_Level)
    is
@@ -318,6 +326,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      Finalize_Lock (Lock (L.all)'Unrestricted_Access);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
       Result : Interfaces.C.int;
    begin
@@ -344,6 +357,13 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L : not null access RW_Lock; Ceiling_Violation : out Boolean)
+   is
+   begin
+      Write_Lock (Lock (L.all)'Unrestricted_Access, Ceiling_Violation);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is
@@ -369,7 +389,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L : not null access Lock; Ceiling_Violation : out Boolean) is
+     (L : not null access RW_Lock; Ceiling_Violation : out Boolean) is
    begin
       Write_Lock (L, Ceiling_Violation);
    end Read_Lock;
@@ -385,6 +405,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      Unlock (Lock (L.all)'Unrestricted_Access);
+   end Unlock;
+
    procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)

gcc/ada/s-taprop-linux.adb

@@ -277,6 +277,34 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+      pragma Unreferenced (Prio);
+
+      RWlock_Attr : aliased pthread_rwlockattr_t;
+      Result      : Interfaces.C.int;
+
+   begin
+      --  Set the rwlock to prefer writer to avoid writers starvation
+
+      Result := pthread_rwlockattr_init (RWlock_Attr'Access);
+      pragma Assert (Result = 0);
+
+      Result := pthread_rwlockattr_setkind_np
+        (RWlock_Attr'Access, PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP);
+      pragma Assert (Result = 0);
+
+      Result := pthread_rwlock_init (L, RWlock_Attr'Access);
+
+      pragma Assert (Result = 0 or else Result = ENOMEM);
+
+      if Result = ENOMEM then
+         raise Storage_Error with "Failed to allocate a lock";
+      end if;
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L     : not null access RTS_Lock;
       Level : Lock_Level)
    is
@@ -309,6 +337,13 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+      Result : Interfaces.C.int;
+   begin
+      Result := pthread_rwlock_destroy (L);
+      pragma Assert (Result = 0);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
       Result : Interfaces.C.int;
    begin
@@ -335,6 +370,20 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L                 : not null access RW_Lock;
+      Ceiling_Violation : out Boolean)
+   is
+      Result : Interfaces.C.int;
+   begin
+      Result := pthread_rwlock_wrlock (L);
+      Ceiling_Violation := Result = EINVAL;
+
+      --  Assume the cause of EINVAL is a priority ceiling violation
+
+      pragma Assert (Result = 0 or else Result = EINVAL);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is
@@ -360,11 +409,17 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L                 : not null access Lock;
+     (L                 : not null access RW_Lock;
       Ceiling_Violation : out Boolean)
    is
+      Result : Interfaces.C.int;
    begin
-      Write_Lock (L, Ceiling_Violation);
+      Result := pthread_rwlock_rdlock (L);
+      Ceiling_Violation := Result = EINVAL;
+
+      --  Assume the cause of EINVAL is a priority ceiling violation
+
+      pragma Assert (Result = 0 or else Result = EINVAL);
    end Read_Lock;
 
    ------------
@@ -378,6 +433,13 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+      Result : Interfaces.C.int;
+   begin
+      Result := pthread_rwlock_unlock (L);
+      pragma Assert (Result = 0);
+   end Unlock;
+
    procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)

gcc/ada/s-taprop-mingw.adb

@@ -415,6 +415,14 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+   begin
+      Initialize_Lock (Prio, Lock (L.all)'Unrestricted_Access);
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L : not null access RTS_Lock; Level : Lock_Level)
    is
       pragma Unreferenced (Level);
@@ -431,6 +439,11 @@ package body System.Task_Primitives.Operations is
       DeleteCriticalSection (L.Mutex'Access);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      Finalize_Lock (Lock (L.all)'Unrestricted_Access);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
    begin
       DeleteCriticalSection (L);
@@ -456,6 +469,12 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L : not null access RW_Lock; Ceiling_Violation : out Boolean) is
+   begin
+      Write_Lock (Lock (L.all)'Unrestricted_Access, Ceiling_Violation);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is
@@ -477,7 +496,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L : not null access Lock; Ceiling_Violation : out Boolean) is
+     (L : not null access RW_Lock; Ceiling_Violation : out Boolean) is
    begin
       Write_Lock (L, Ceiling_Violation);
    end Read_Lock;
@@ -491,6 +510,11 @@ package body System.Task_Primitives.Operations is
       LeaveCriticalSection (L.Mutex'Access);
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      Unlock (Lock (L.all)'Unrestricted_Access);
+   end Unlock;
+
    procedure Unlock
      (L : not null access RTS_Lock; Global_Lock : Boolean := False) is
    begin

gcc/ada/s-taprop-posix.adb

@@ -323,6 +323,14 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+   begin
+      Initialize_Lock (Prio, Lock (L.all)'Unrestricted_Access);
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L : not null access RTS_Lock; Level : Lock_Level)
    is
       pragma Unreferenced (Level);
@@ -376,6 +384,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      Finalize_Lock (Lock (L.all)'Unrestricted_Access);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
       Result : Interfaces.C.int;
    begin
@@ -402,6 +415,13 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L : not null access RW_Lock; Ceiling_Violation : out Boolean)
+   is
+   begin
+      Write_Lock (Lock (L.all)'Unrestricted_Access, Ceiling_Violation);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is
@@ -427,7 +447,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L : not null access Lock; Ceiling_Violation : out Boolean) is
+     (L : not null access RW_Lock; Ceiling_Violation : out Boolean) is
    begin
       Write_Lock (L, Ceiling_Violation);
    end Read_Lock;
@@ -443,6 +463,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      Unlock (Lock (L.all)'Unrestricted_Access);
+   end Unlock;
+
    procedure Unlock
      (L : not null access RTS_Lock; Global_Lock : Boolean := False)
    is

gcc/ada/s-taprop-solaris.adb

@@ -564,6 +564,14 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+   begin
+      Initialize_Lock (Prio, Lock (L.all)'Unrestricted_Access);
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L     : not null access RTS_Lock;
       Level : Lock_Level)
    is
@@ -592,6 +600,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      Finalize_Lock (Lock (L.all)'Unrestricted_Access);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
       Result : Interfaces.C.int;
    begin
@@ -647,6 +660,14 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L                 : not null access RW_Lock;
+      Ceiling_Violation : out Boolean)
+   is
+   begin
+      Write_Lock (Lock (L.all)'Unrestricted_Access, Ceiling_Violation);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L          : not null access RTS_Lock;
      Global_Lock : Boolean := False)
    is
@@ -676,7 +697,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L                 : not null access Lock;
+     (L                 : not null access RW_Lock;
       Ceiling_Violation : out Boolean) is
    begin
       Write_Lock (L, Ceiling_Violation);
@@ -710,6 +731,11 @@ package body System.Task_Primitives.Operations is
       end if;
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      Unlock (Lock (L.all)'Unrestricted_Access);
+   end Unlock;
+
    procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)

gcc/ada/s-taprop-tru64.adb

@@ -266,6 +266,14 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+   begin
+      Initialize_Lock (Prio, Lock (L.all)'Unrestricted_Access);
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L     : not null access RTS_Lock;
       Level : Lock_Level)
    is
@@ -305,6 +313,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      Finalize_Lock (Lock (L.all)'Unrestricted_Access);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
       Result : Interfaces.C.int;
    begin
@@ -350,6 +363,14 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L                 : not null access RW_Lock;
+      Ceiling_Violation : out Boolean)
+   is
+   begin
+      Write_Lock (Lock (L.all)'Unrestricted_Access, Ceiling_Violation);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is
@@ -375,7 +396,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L                 : not null access Lock;
+     (L                 : not null access RW_Lock;
       Ceiling_Violation : out Boolean)
    is
    begin
@@ -393,6 +414,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      Unlock (Lock (L.all)'Unrestricted_Access);
+   end Unlock;
+
    procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)

gcc/ada/s-taprop-vms.adb

@@ -226,6 +226,13 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock) is
+   begin
+      Initialize_Lock (Prio, Lock (L.all)'Unrestricted_Access);
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L     : not null access RTS_Lock;
       Level : Lock_Level)
    is
@@ -278,6 +285,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      Finalize_Lock (Lock (L.all)'Unrestricted_Access);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
       Result : Interfaces.C.int;
    begin
@@ -320,6 +332,14 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L                 : not null access RW_Lock;
+      Ceiling_Violation : out Boolean)
+   is
+   begin
+      Write_Lock (Lock (L.all)'Unrestricted_Access, Ceiling_Violation);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is
@@ -345,7 +365,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L                 : not null access Lock;
+     (L                 : not null access RW_Lock;
       Ceiling_Violation : out Boolean)
    is
    begin
@@ -363,6 +383,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      Unlock (Lock (L.all)'Unrestricted_Access);
+   end Unlock;
+
    procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)

gcc/ada/s-taprop-vxworks.adb

@@ -309,6 +309,14 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock)
+   is
+   begin
+      Initialize_Lock (Prio, Lock (L.all)'Unrestricted_Access);
+   end Initialize_Lock;
+
+   procedure Initialize_Lock
      (L     : not null access RTS_Lock;
       Level : Lock_Level)
    is
@@ -331,6 +339,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Finalize_Lock;
 
+   procedure Finalize_Lock (L : not null access RW_Lock) is
+   begin
+      Finalize_Lock (Lock (L.all)'Unrestricted_Access);
+   end Finalize_Lock;
+
    procedure Finalize_Lock (L : not null access RTS_Lock) is
       Result : int;
    begin
@@ -363,6 +376,14 @@ package body System.Task_Primitives.Operations is
    end Write_Lock;
 
    procedure Write_Lock
+     (L                 : not null access RW_Lock;
+      Ceiling_Violation : out Boolean)
+   is
+   begin
+      Write_Lock (Lock (L.all)'Unrestricted_Access, Ceiling_Violation);
+   end Write_Lock;
+
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)
    is
@@ -388,7 +409,7 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L                 : not null access Lock;
+     (L                 : not null access RW_Lock;
       Ceiling_Violation : out Boolean)
    is
    begin
@@ -406,6 +427,11 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
    end Unlock;
 
+   procedure Unlock (L : not null access RW_Lock) is
+   begin
+      Unlock (Lock (L.all)'Unrestricted_Access);
+   end Unlock;
+
    procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False)

gcc/ada/s-taprop.ads

@@ -149,6 +149,9 @@ package System.Task_Primitives.Operations is
      (Prio : System.Any_Priority;
       L    : not null access Lock);
    procedure Initialize_Lock
+     (Prio : System.Any_Priority;
+      L    : not null access RW_Lock);
+   procedure Initialize_Lock
      (L     : not null access RTS_Lock;
       Level : Lock_Level);
    pragma Inline (Initialize_Lock);
@@ -173,6 +176,7 @@ package System.Task_Primitives.Operations is
    --  These operations raise Storage_Error if a lack of storage is detected
 
    procedure Finalize_Lock (L : not null access Lock);
+   procedure Finalize_Lock (L : not null access RW_Lock);
    procedure Finalize_Lock (L : not null access RTS_Lock);
    pragma Inline (Finalize_Lock);
    --  Finalize a lock object, freeing any resources allocated by the
@@ -182,6 +186,9 @@ package System.Task_Primitives.Operations is
      (L                 : not null access Lock;
       Ceiling_Violation : out Boolean);
    procedure Write_Lock
+     (L                 : not null access RW_Lock;
+      Ceiling_Violation : out Boolean);
+   procedure Write_Lock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False);
    procedure Write_Lock
@@ -210,7 +217,7 @@ package System.Task_Primitives.Operations is
    --  per-task lock is implicit in Exit_Task.
 
    procedure Read_Lock
-     (L                 : not null access Lock;
+     (L                 : not null access RW_Lock;
       Ceiling_Violation : out Boolean);
    pragma Inline (Read_Lock);
    --  Lock a lock object for read access. After this operation returns,
@@ -236,6 +243,8 @@ package System.Task_Primitives.Operations is
    procedure Unlock
      (L : not null access Lock);
    procedure Unlock
+     (L : not null access RW_Lock);
+   procedure Unlock
      (L           : not null access RTS_Lock;
       Global_Lock : Boolean := False);
    procedure Unlock

gcc/ada/s-taspri-dummy.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 1991-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1991-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- --
@@ -40,6 +40,8 @@ package System.Task_Primitives is
 
    type Lock is new Integer;
 
+   type RW_Lock is new Integer;
+
    type RTS_Lock is new Integer;
 
    type Suspension_Object is new Integer;

gcc/ada/s-taspri-hpux-dce.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 1991-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1991-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- --
@@ -43,6 +43,7 @@ package System.Task_Primitives is
    pragma Preelaborate;
 
    type Lock is limited private;
+   type RW_Lock is limited private;
    --  Should be used for implementation of protected objects
 
    type RTS_Lock is limited private;
@@ -81,6 +82,8 @@ private
       Owner_Priority : Integer;
    end record;
 
+   type RW_Lock is new Lock;
+
    type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
 
    type Suspension_Object is record

gcc/ada/s-taspri-mingw.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 1991-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1991-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- --
@@ -42,6 +42,7 @@ package System.Task_Primitives is
    pragma Preelaborate;
 
    type Lock is limited private;
+   type RW_Lock is limited private;
    --  Should be used for implementation of protected objects
 
    type RTS_Lock is limited private;
@@ -81,6 +82,8 @@ private
       Owner_Priority : Integer;
    end record;
 
+   type RW_Lock is new Lock;
+
    type Condition_Variable is new System.Win32.HANDLE;
 
    type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION;

gcc/ada/s-taspri-posix-noaltstack.ads

@@ -7,7 +7,7 @@
 --                                  S p e c                                 --
 --                                                                          --
 --             Copyright (C) 1991-1994, Florida State University            --
---                     Copyright (C) 1995-2010, AdaCore                     --
+--                     Copyright (C) 1995-2011, AdaCore                     --
 --                                                                          --
 -- GNAT 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- --
@@ -45,6 +45,7 @@ package System.Task_Primitives is
    pragma Preelaborate;
 
    type Lock is limited private;
+   type RW_Lock is limited private;
    --  Should be used for implementation of protected objects
 
    type RTS_Lock is limited private;
@@ -79,6 +80,7 @@ package System.Task_Primitives is
 private
 
    type Lock is new System.OS_Interface.pthread_mutex_t;
+   type RW_Lock is new Lock;
    type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
 
    type Suspension_Object is record

gcc/ada/s-taspri-posix.ads

@@ -44,6 +44,7 @@ package System.Task_Primitives is
    pragma Preelaborate;
 
    type Lock is limited private;
+   type RW_Lock is limited private;
    --  Should be used for implementation of protected objects
 
    type RTS_Lock is limited private;
@@ -78,6 +79,7 @@ package System.Task_Primitives is
 private
 
    type Lock is new System.OS_Interface.pthread_mutex_t;
+   type RW_Lock is new System.OS_Interface.pthread_rwlock_t;
    type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
 
    type Suspension_Object is record

gcc/ada/s-taspri-solaris.ads

@@ -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- --
@@ -46,6 +46,7 @@ package System.Task_Primitives is
 
    type Lock is limited private;
    type Lock_Ptr is access all Lock;
+   type RW_Lock is limited private;
    --  Should be used for implementation of protected objects
 
    type RTS_Lock is limited private;
@@ -107,6 +108,8 @@ private
       Frozen         : Boolean := False;
    end record;
 
+   type RW_Lock is new Lock;
+
    type RTS_Lock is new Lock;
 
    type Suspension_Object is record

gcc/ada/s-taspri-tru64.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 1991-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1991-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- --
@@ -45,6 +45,7 @@ package System.Task_Primitives is
    pragma Preelaborate;
 
    type Lock is limited private;
+   type RW_Lock is limited private;
    --  Should be used for implementation of protected objects
 
    type RTS_Lock is limited private;
@@ -82,6 +83,8 @@ private
       Ceiling : Interfaces.C.int;
    end record;
 
+   type RW_Lock is new Lock;
+
    type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
 
    type Suspension_Object is record

gcc/ada/s-taspri-vms.ads

@@ -46,6 +46,7 @@ package System.Task_Primitives is
    pragma Preelaborate;
 
    type Lock is limited private;
+   type RW_Lock is limited private;
    --  Should be used for implementation of protected objects
 
    type RTS_Lock is limited private;
@@ -84,6 +85,8 @@ private
       Prio_Save : Interfaces.C.int;
    end record;
 
+   type RW_Lock is new Lock;
+
    type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
 
    type Suspension_Object is record

gcc/ada/s-taspri-vxworks.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 2001-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 2001-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- --
@@ -41,6 +41,7 @@ package System.Task_Primitives is
    pragma Preelaborate;
 
    type Lock is limited private;
+   type RW_Lock is limited private;
    --  Should be used for implementation of protected objects
 
    type RTS_Lock is limited private;
@@ -84,6 +85,8 @@ private
       --  Priority ceiling of lock
    end record;
 
+   type RW_Lock is new Lock;
+
    type RTS_Lock is new Lock;
 
    type Suspension_Object is record

gcc/ada/s-tpoben.adb

@@ -88,7 +88,11 @@ package body System.Tasking.Protected_Objects.Entries is
          return;
       end if;
 
+      if Locking_Policy = 'R' then
+         STPO.Write_Lock (Object.RWL'Unrestricted_Access, Ceiling_Violation);
+      else
          STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
+      end if;
 
       if Single_Lock then
          Lock_RTS;
@@ -109,7 +113,12 @@ package body System.Tasking.Protected_Objects.Entries is
             Unlock_RTS;
          end if;
 
+         if Locking_Policy = 'R' then
+            STPO.Write_Lock
+              (Object.RWL'Unrestricted_Access, Ceiling_Violation);
+         else
             STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
+         end if;
 
          if Ceiling_Violation then
             raise Program_Error with "Ceiling Violation";
@@ -149,9 +158,13 @@ package body System.Tasking.Protected_Objects.Entries is
          Unlock_RTS;
       end if;
 
+      if Locking_Policy = 'R' then
+         STPO.Unlock (Object.RWL'Unrestricted_Access);
+         STPO.Finalize_Lock (Object.RWL'Unrestricted_Access);
+      else
          STPO.Unlock (Object.L'Unrestricted_Access);
-
          STPO.Finalize_Lock (Object.L'Unrestricted_Access);
+      end if;
    end Finalize;
 
    ----------------------
@@ -234,7 +247,13 @@ package body System.Tasking.Protected_Objects.Entries is
       --  pragma Assert (Self_Id.Deferral_Level = 0);
 
       Initialization.Defer_Abort_Nestable (Self_ID);
+
+      if Locking_Policy = 'R' then
+         Initialize_Lock (Init_Priority, Object.RWL'Access);
+      else
          Initialize_Lock (Init_Priority, Object.L'Access);
+      end if;
+
       Initialization.Undefer_Abort_Nestable (Self_ID);
 
       Object.Ceiling          := System.Any_Priority (Init_Priority);
@@ -310,7 +329,11 @@ package body System.Tasking.Protected_Objects.Entries is
         (STPO.Self.Deferral_Level > 0
           or else not Restrictions.Abort_Allowed);
 
+      if Locking_Policy = 'R' then
+         Write_Lock (Object.RWL'Access, Ceiling_Violation);
+      else
          Write_Lock (Object.L'Access, Ceiling_Violation);
+      end if;
 
       --  We are entering in a protected action, so that we increase the
       --  protected object nesting level (if pragma Detect_Blocking is
@@ -364,7 +387,11 @@ package body System.Tasking.Protected_Objects.Entries is
          raise Program_Error;
       end if;
 
-      Read_Lock (Object.L'Access, Ceiling_Violation);
+      if Locking_Policy = 'R' then
+         Read_Lock (Object.RWL'Access, Ceiling_Violation);
+      else
+         Write_Lock (Object.L'Access, Ceiling_Violation);
+      end if;
 
       if Ceiling_Violation then
          raise Program_Error with "Ceiling Violation";
@@ -460,7 +487,11 @@ package body System.Tasking.Protected_Objects.Entries is
          Object.Ceiling := Object.New_Ceiling;
       end if;
 
+      if Locking_Policy = 'R' then
+         Unlock (Object.RWL'Access);
+      else
          Unlock (Object.L'Access);
+      end if;
    end Unlock_Entries;
 
 end System.Tasking.Protected_Objects.Entries;

gcc/ada/s-tpoben.ads

@@ -77,6 +77,7 @@ package System.Tasking.Protected_Objects.Entries is
      Ada.Finalization.Limited_Controlled
    with record
       L   : aliased Task_Primitives.Lock;
+      RWL : aliased Task_Primitives.RW_Lock;
       --  The underlying lock associated with a Protection_Entries.
       --  Note that you should never (un)lock Object.L directly, but instead
       --  use Lock_Entries/Unlock_Entries.