Skip to content

R
riscv-gcc-1
Commit 7a44cb69 by Pascal Obry Committed by Arnaud Charlet
Options

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
parent 4c173b50
Showing with 462 additions and 40 deletions
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
......@@ -6,8 +6,8 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, AdaCore --
-- Copyright (C) 1991-1994, Florida State University --
-- 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
Finalize_Lock (Object.L'Unrestricted_Access);
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;
Initialize_Lock (Init_Priority, Object.L'Access);
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;
Write_Lock (Object.L'Access, Ceiling_Violation);
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;
Unlock (Object.L'Access);
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;
STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
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;
STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
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;
STPO.Unlock (Object.L'Unrestricted_Access);
STPO.Finalize_Lock (Object.L'Unrestricted_Access);
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);
Initialize_Lock (Init_Priority, Object.L'Access);
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);
Write_Lock (Object.L'Access, Ceiling_Violation);
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;
Unlock (Object.L'Access);
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
......@@ -76,7 +76,8 @@ package System.Tasking.Protected_Objects.Entries is
type Protection_Entries (Num_Entries : Protected_Entry_Index) is new
Ada.Finalization.Limited_Controlled
with record
L : aliased Task_Primitives.Lock;
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.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment