FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Remove System.Parameters.Single_Lock

Browse source 
2020-06-04  Arnaud Charlet  <charlet@adacore.com>

gcc/ada/

	* libgnarl/a-dynpri.adb, libgnarl/a-taside.adb,
	libgnarl/a-taster.adb, libgnarl/s-interr.adb,
	libgnarl/s-interr__sigaction.adb, libgnarl/s-taasde.adb,
	libgnarl/s-taenca.adb, libgnarl/s-taenca.ads,
	libgnarl/s-taprop.ads, libgnarl/s-taprop__hpux-dce.adb,
	libgnarl/s-taprop__linux.adb, libgnarl/s-taprop__mingw.adb,
	libgnarl/s-taprop__posix.adb, libgnarl/s-taprop__qnx.adb,
	libgnarl/s-taprop__solaris.adb, libgnarl/s-taprop__vxworks.adb,
	libgnarl/s-tarest.adb, libgnarl/s-tasini.adb,
	libgnarl/s-tasque.adb, libgnarl/s-tasque.ads,
	libgnarl/s-tasren.adb, libgnarl/s-tasren.ads,
	libgnarl/s-tassta.adb, libgnarl/s-tasuti.adb,
	libgnarl/s-tasuti.ads, libgnarl/s-tpoben.adb,
	libgnarl/s-tpobop.adb, libgnarl/s-tpopmo.adb,
	libgnarl/s-tposen.adb, libgnat/s-parame.ads,
	libgnat/s-parame__ae653.ads, libgnat/s-parame__hpux.ads,
	libgnat/s-parame__vxworks.ads: Remove references to Single_Lock
	and Global_Lock.
This commit is contained in:
Arnaud Charlet 2020-01-21 06:44:25 -05:00 • committed by Pierre-Marie de Rodat
parent bbe376e136
commit b68c1670b7
33 changed files with 287 additions and 1379 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/ada/libgnarl/a-dynpri.adb
View file

@ -31,7 +31,6 @@
with System.Task_Primitives.Operations;
with System.Tasking;
with System.Parameters;
with System.Soft_Links;
with Ada.Unchecked_Conversion;
@ -41,7 +40,6 @@ package body Ada.Dynamic_Priorities is
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
use System.Parameters;
use System.Tasking;
function Convert_Ids is new
@ -103,10 +101,6 @@ package body Ada.Dynamic_Priorities is
SSL.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Target);
Target.Common.Base_Priority := Priority;
@ -141,10 +135,6 @@ package body Ada.Dynamic_Priorities is
STPO.Unlock (Target);
if Single_Lock then
STPO.Unlock_RTS;
end if;
if STPO.Self = Target and then Yield_Needed then
-- Yield is needed to enforce FIFO task dispatching

26
gcc/ada/libgnarl/a-taside.adb
View file

@ -30,7 +30,6 @@
------------------------------------------------------------------------------
with System.Address_Image;
with System.Parameters;
with System.Soft_Links;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
@ -48,9 +47,6 @@ pragma Warnings (On);
package body Ada.Task_Identification with
SPARK_Mode => Off
is
use System.Parameters;
package STPO renames System.Task_Primitives.Operations;
-----------------------
@ -165,20 +161,11 @@ is
raise Program_Error;
else
System.Soft_Links.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Id);
Result := Id.Callable;
STPO.Unlock (Id);
if Single_Lock then
STPO.Unlock_RTS;
end if;
System.Soft_Links.Abort_Undefer.all;
return Result;
end if;
end Is_Callable;
@ -198,20 +185,11 @@ is
raise Program_Error;
else
System.Soft_Links.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Id);
Result := Id.Common.State = Terminated;
STPO.Unlock (Id);
if Single_Lock then
STPO.Unlock_RTS;
end if;
System.Soft_Links.Abort_Undefer.all;
return Result;
end if;
end Is_Terminated;

33
gcc/ada/libgnarl/a-taster.adb
View file

@ -31,7 +31,6 @@
with System.Tasking;
with System.Task_Primitives.Operations;
with System.Parameters;
with System.Soft_Links;
with Ada.Unchecked_Conversion;
@ -43,8 +42,6 @@ package body Ada.Task_Termination is
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
use System.Parameters;
-----------------------
-- Local subprograms --
-----------------------
@ -82,21 +79,11 @@ package body Ada.Task_Termination is
begin
SSL.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self);
Self.Common.Fall_Back_Handler := To_ST (Handler);
STPO.Unlock (Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
SSL.Abort_Undefer.all;
end Set_Dependents_Fallback_Handler;
@ -123,21 +110,11 @@ package body Ada.Task_Termination is
begin
SSL.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Target);
Target.Common.Specific_Handler := To_ST (Handler);
STPO.Unlock (Target);
if Single_Lock then
STPO.Unlock_RTS;
end if;
SSL.Abort_Undefer.all;
end;
end if;
@ -166,21 +143,11 @@ package body Ada.Task_Termination is
begin
SSL.Abort_Defer.all;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Target);
TH := To_TT (Target.Common.Specific_Handler);
STPO.Unlock (Target);
if Single_Lock then
STPO.Unlock_RTS;
end if;
SSL.Abort_Undefer.all;
return TH;

41
gcc/ada/libgnarl/s-interr.adb
View file

@ -1288,11 +1288,6 @@ package body System.Interrupts is
loop
System.Tasking.Initialization.Defer_Abort (Self_ID);
if Single_Lock then
POP.Lock_RTS;
end if;
POP.Write_Lock (Self_ID);
if User_Handler (Interrupt).H = null
@ -1327,10 +1322,6 @@ package body System.Interrupts is
Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
POP.Unlock (Self_ID);
if Single_Lock then
POP.Unlock_RTS;
end if;
-- Avoid race condition when terminating application and
-- System.Parameters.No_Abort is True.
@ -1347,18 +1338,9 @@ package body System.Interrupts is
-- Inform the Interrupt_Manager of wakeup from above sigwait
POP.Abort_Task (Interrupt_Manager_ID);
if Single_Lock then
POP.Lock_RTS;
end if;
POP.Write_Lock (Self_ID);
else
if Single_Lock then
POP.Lock_RTS;
end if;
POP.Write_Lock (Self_ID);
if Ret_Interrupt /= Interrupt then
@ -1383,17 +1365,7 @@ package body System.Interrupts is
-- RTS calls should not be made with self being locked
POP.Unlock (Self_ID);
if Single_Lock then
POP.Unlock_RTS;
end if;
Tmp_Handler.all;
if Single_Lock then
POP.Lock_RTS;
end if;
POP.Write_Lock (Self_ID);
elsif User_Entry (Interrupt).T /= Null_Task then
@ -1402,10 +1374,6 @@ package body System.Interrupts is
-- RTS calls should not be made with self being locked
if Single_Lock then
POP.Unlock_RTS;
end if;
POP.Unlock (Self_ID);
System.Tasking.Rendezvous.Call_Simple
@ -1413,10 +1381,6 @@ package body System.Interrupts is
POP.Write_Lock (Self_ID);
if Single_Lock then
POP.Lock_RTS;
end if;
else
-- This is a situation that this task wakes up receiving
-- an Interrupt and before it gets the lock the Interrupt
@ -1432,11 +1396,6 @@ package body System.Interrupts is
end if;
POP.Unlock (Self_ID);
if Single_Lock then
POP.Unlock_RTS;
end if;
System.Tasking.Initialization.Undefer_Abort (Self_ID);
if Self_ID.Pending_Action then

12
gcc/ada/libgnarl/s-interr__sigaction.adb
View file

@ -42,11 +42,9 @@ with System.Tasking.Utilities;
with System.Tasking.Rendezvous;
with System.Tasking.Initialization;
with System.Interrupt_Management;
with System.Parameters;
package body System.Interrupts is
use Parameters;
use Tasking;
use System.OS_Interface;
use Interfaces.C;
@ -644,21 +642,11 @@ package body System.Interrupts is
end loop;
Initialization.Defer_Abort (Self_Id);
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
Self_Id.Common.State := Runnable;
STPO.Unlock (Self_Id);
if Single_Lock then
STPO.Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
-- Undefer abort here to allow a window for this task to be aborted

31
gcc/ada/libgnarl/s-taasde.adb
View file

@ -51,8 +51,6 @@ package body System.Tasking.Async_Delays is
package STI renames System.Tasking.Initialization;
package OSP renames System.OS_Primitives;
use Parameters;
function To_System is new Ada.Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_Id);
@ -118,11 +116,6 @@ package body System.Tasking.Async_Delays is
-- Remove self from timer queue
STI.Defer_Abort_Nestable (D.Self_Id);
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Timer_Server_ID);
Dpred := D.Pred;
Dsucc := D.Succ;
@ -141,11 +134,6 @@ package body System.Tasking.Async_Delays is
STPO.Write_Lock (D.Self_Id);
STU.Exit_One_ATC_Level (D.Self_Id);
STPO.Unlock (D.Self_Id);
if Single_Lock then
STPO.Unlock_RTS;
end if;
STI.Undefer_Abort_Nestable (D.Self_Id);
end Cancel_Async_Delay;
@ -217,11 +205,6 @@ package body System.Tasking.Async_Delays is
D.Level := Self_Id.ATC_Nesting_Level;
D.Self_Id := Self_Id;
D.Resume_Time := T;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Timer_Server_ID);
-- Previously, there was code here to dynamically create
@ -258,10 +241,6 @@ package body System.Tasking.Async_Delays is
end if;
STPO.Unlock (Timer_Server_ID);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end Time_Enqueue;
---------------
@ -305,11 +284,6 @@ package body System.Tasking.Async_Delays is
loop
STI.Defer_Abort (Timer_Server_ID);
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Timer_Server_ID);
-- The timer server needs to catch pending aborts after finalization
@ -383,11 +357,6 @@ package body System.Tasking.Async_Delays is
-- an actual delay in this server.
STPO.Unlock (Timer_Server_ID);
if Single_Lock then
STPO.Unlock_RTS;
end if;
STI.Undefer_Abort (Timer_Server_ID);
end loop;
end Timer_Server;

82
gcc/ada/libgnarl/s-taenca.adb
View file

@ -35,13 +35,11 @@ with System.Tasking.Protected_Objects.Entries;
with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Queuing;
with System.Tasking.Utilities;
with System.Parameters;
package body System.Tasking.Entry_Calls is
package STPO renames System.Task_Primitives.Operations;
use Parameters;
use Protected_Objects.Entries;
use Protected_Objects.Operations;
@ -71,24 +69,18 @@ package body System.Tasking.Entry_Calls is
-- permitted. Since the server cannot be obtained reliably, it must be
-- obtained unreliably and then checked again once it has been locked.
--
-- If Single_Lock and server is a PO, release RTS_Lock
--
-- This should only be called by the Entry_Call.Self.
-- It should be holding no other ATCB locks at the time.
procedure Unlock_Server (Entry_Call : Entry_Call_Link);
-- STPO.Unlock the server targeted by Entry_Call. The server must
-- be locked before calling this.
--
-- If Single_Lock and server is a PO, take RTS_Lock on exit.
procedure Unlock_And_Update_Server
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
-- Similar to Unlock_Server, but services entry calls if the
-- server is a protected object.
--
-- If Single_Lock and server is a PO, take RTS_Lock on exit.
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_Id;
@ -200,19 +192,9 @@ package body System.Tasking.Entry_Calls is
-- We had very bad luck, interleaving with TWO different
-- requeue operations. Go around the loop and try again.
if Single_Lock then
STPO.Unlock_RTS;
STPO.Yield;
STPO.Lock_RTS;
else
STPO.Yield;
end if;
STPO.Yield;
else
if Single_Lock then
STPO.Unlock_RTS;
end if;
Lock_Entries_With_Status (Test_PO, Ceiling_Violation);
-- ???
@ -232,10 +214,6 @@ package body System.Tasking.Entry_Calls is
Old_Base_Priority : System.Any_Priority;
begin
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Current_Task);
Old_Base_Priority := Current_Task.Common.Base_Priority;
Current_Task.New_Base_Priority := Test_PO.Ceiling;
@ -243,10 +221,6 @@ package body System.Tasking.Entry_Calls is
(Current_Task);
STPO.Unlock (Current_Task);
if Single_Lock then
STPO.Unlock_RTS;
end if;
-- Following lock should not fail
Lock_Entries (Test_PO);
@ -258,10 +232,6 @@ package body System.Tasking.Entry_Calls is
exit when To_Address (Test_PO) = Entry_Call.Called_PO;
Unlock_Entries (Test_PO);
if Single_Lock then
STPO.Lock_RTS;
end if;
end if;
else
@ -343,11 +313,6 @@ package body System.Tasking.Entry_Calls is
pragma Assert (Entry_Call.Mode = Asynchronous_Call);
Initialization.Defer_Abort_Nestable (Self_ID);
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_ID);
Entry_Call.Cancellation_Attempted := True;
@ -357,13 +322,7 @@ package body System.Tasking.Entry_Calls is
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock (Self_ID);
if Single_Lock then
STPO.Unlock_RTS;
end if;
Succeeded := Entry_Call.State = Cancelled;
Initialization.Undefer_Abort_Nestable (Self_ID);
-- Ideally, abort should no longer be deferred at this point, so we
@ -401,26 +360,13 @@ package body System.Tasking.Entry_Calls is
if Called_PO.Pending_Action then
Called_PO.Pending_Action := False;
Caller := STPO.Self;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
Initialization.Change_Base_Priority (Caller);
STPO.Unlock (Caller);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
Unlock_Entries (Called_PO);
if Single_Lock then
STPO.Lock_RTS;
end if;
end if;
end Unlock_And_Update_Server;
@ -441,26 +387,13 @@ package body System.Tasking.Entry_Calls is
if Called_PO.Pending_Action then
Called_PO.Pending_Action := False;
Caller := STPO.Self;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
Initialization.Change_Base_Priority (Caller);
STPO.Unlock (Caller);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
Unlock_Entries (Called_PO);
if Single_Lock then
STPO.Lock_RTS;
end if;
end if;
end Unlock_Server;
@ -481,21 +414,13 @@ package body System.Tasking.Entry_Calls is
-- a chance of getting ready immediately, using Unlock & Yield.
-- See similar action in Wait_For_Call & Timed_Selective_Wait.
if Single_Lock then
STPO.Unlock_RTS;
else
STPO.Unlock (Self_Id);
end if;
STPO.Unlock (Self_Id);
if Entry_Call.State < Done then
STPO.Yield;
end if;
if Single_Lock then
STPO.Lock_RTS;
else
STPO.Write_Lock (Self_Id);
end if;
STPO.Write_Lock (Self_Id);
loop
Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
@ -507,7 +432,6 @@ package body System.Tasking.Entry_Calls is
Self_Id.Common.State := Runnable;
Utilities.Exit_One_ATC_Level (Self_Id);
end Wait_For_Completion;
--------------------------------------

3
gcc/ada/libgnarl/s-taenca.ads
View file

@ -61,8 +61,7 @@ package System.Tasking.Entry_Calls is
Call : Entry_Call_Link);
-- This procedure suspends the calling task until the specified entry
-- call is queued abortably or completes.
-- Abortion must be deferred when calling this procedure, and the global
-- RTS lock taken when Single_Lock.
-- Abortion must be deferred when calling this procedure.
procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean);
pragma Inline (Try_To_Cancel_Entry_Call);

25
gcc/ada/libgnarl/s-taprop.ads
View file

@ -181,11 +181,8 @@ package System.Task_Primitives.Operations is
procedure Write_Lock
(L : not null access Lock;
Ceiling_Violation : out Boolean);
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False);
procedure Write_Lock
(T : ST.Task_Id);
procedure Write_Lock (L : not null access RTS_Lock);
procedure Write_Lock (T : ST.Task_Id);
pragma Inline (Write_Lock);
-- Lock a lock object for write access. After this operation returns,
-- the calling task holds write permission for the lock object. No other
@ -198,9 +195,6 @@ package System.Task_Primitives.Operations is
-- operation failed, which will happen if there is a priority ceiling
-- violation.
--
-- For the operation on RTS_Lock, Global_Lock should be set to True
-- if L is a global lock (Single_RTS_Lock, Global_Task_Lock).
--
-- For the operation on ST.Task_Id, the lock is the special lock object
-- associated with that task's ATCB. This lock has effective ceiling
-- priority high enough that it is safe to call by a task with any
@ -235,11 +229,8 @@ package System.Task_Primitives.Operations is
procedure Unlock
(L : not null access Lock);
procedure Unlock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False);
procedure Unlock
(T : ST.Task_Id);
procedure Unlock (L : not null access RTS_Lock);
procedure Unlock (T : ST.Task_Id);
pragma Inline (Unlock);
-- Unlock a locked lock object
--
@ -249,9 +240,6 @@ package System.Task_Primitives.Operations is
-- read or write permission. (That is, matching pairs of Lock and Unlock
-- operations on each lock object must be properly nested.)
-- For the operation on RTS_Lock, Global_Lock should be set to True if L
-- is a global lock (Single_RTS_Lock, Global_Task_Lock).
--
-- Note that Write_Lock for RTS_Lock does not have an out-parameter.
-- RTS_Locks are used in situations where we have not made provision for
-- recovery from ceiling violations. We do not expect them to occur inside
@ -424,10 +412,7 @@ package System.Task_Primitives.Operations is
-- Following two routines are used for possible operations needed to be
-- setup/cleared upon entrance/exit of RTS while maintaining a single
-- thread of control in the RTS. Since we intend these routines to be used
-- for implementing the Single_Lock RTS, Lock_RTS should follow the first
-- Defer_Abort operation entering RTS. In the same fashion Unlock_RTS
-- should precede the last Undefer_Abort exiting RTS.
-- thread of control in the RTS.
--
-- These routines also replace the functions Lock/Unlock_All_Tasks_List

105
gcc/ada/libgnarl/s-taprop__hpux-dce.adb
View file

@ -83,7 +83,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-- Used to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
@ -325,25 +325,18 @@ package body System.Task_Primitives.Operations is
Ceiling_Violation := False;
end Write_Lock;
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Write_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_lock (L);
pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_lock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end Write_Lock;
---------------
@ -369,25 +362,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
procedure Unlock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Unlock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end Unlock;
-----------------
@ -421,9 +407,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_wait
(cond => Self_ID.Common.LL.CV'Access,
mutex => (if Single_Lock
then Single_RTS_Lock'Access
else Self_ID.Common.LL.L'Access));
mutex => Self_ID.Common.LL.L'Access);
-- EINTR is not considered a failure
@ -467,9 +451,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_timedwait
(cond => Self_ID.Common.LL.CV'Access,
mutex => (if Single_Lock
then Single_RTS_Lock'Access
else Self_ID.Common.LL.L'Access),
mutex => Self_ID.Common.LL.L'Access,
abstime => Request'Access);
exit when Abs_Time <= Monotonic_Clock;
@ -504,10 +486,6 @@ package body System.Task_Primitives.Operations is
pragma Warnings (Off, Result);
begin
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID);
Abs_Time :=
@ -525,9 +503,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_timedwait
(cond => Self_ID.Common.LL.CV'Access,
mutex => (if Single_Lock
then Single_RTS_Lock'Access
else Self_ID.Common.LL.L'Access),
mutex => Self_ID.Common.LL.L'Access,
abstime => Request'Access);
exit when Abs_Time <= Monotonic_Clock;
@ -541,11 +517,6 @@ package body System.Task_Primitives.Operations is
end if;
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
Result := sched_yield;
end Timed_Delay;
@ -733,26 +704,24 @@ package body System.Task_Primitives.Operations is
Cond_Attr : aliased pthread_condattr_t;
begin
if not Single_Lock then
Result := pthread_mutexattr_init (Mutex_Attr'Access);
Result := pthread_mutexattr_init (Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
Result :=
pthread_mutex_init
(Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
Result :=
pthread_mutex_init
(Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
if Result /= 0 then
Succeeded := False;
return;
end if;
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
pragma Assert (Result = 0);
end if;
if Result /= 0 then
Succeeded := False;
return;
end if;
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
pragma Assert (Result = 0);
Result := pthread_condattr_init (Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
@ -767,10 +736,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
if not Single_Lock then
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
Succeeded := False;
end if;
@ -841,10 +808,8 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
pragma Assert (Result = 0);
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@ -1093,7 +1058,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@ -1102,7 +1067,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------

66
gcc/ada/libgnarl/s-taprop__linux.adb
View file

@ -75,7 +75,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-- Used to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
@ -304,7 +304,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@ -313,7 +313,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
-----------------
@ -484,25 +484,18 @@ package body System.Task_Primitives.Operations is
Ceiling_Violation := Result = EINVAL;
end Write_Lock;
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Write_Lock (L : not null access RTS_Lock) is
Result : C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_lock (L);
pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : C.int;
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_lock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end Write_Lock;
---------------
@ -542,25 +535,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
procedure Unlock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Unlock (L : not null access RTS_Lock) is
Result : C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : C.int;
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end Unlock;
-----------------
@ -596,9 +582,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_wait
(cond => Self_ID.Common.LL.CV'Access,
mutex => (if Single_Lock
then Single_RTS_Lock'Access
else Self_ID.Common.LL.L'Access));
mutex => Self_ID.Common.LL.L'Access);
-- EINTR is not considered a failure
@ -860,13 +844,9 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.Thread := Null_Thread_Id;
if not Single_Lock then
if Init_Mutex
(Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0
then
Succeeded := False;
return;
end if;
if Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0 then
Succeeded := False;
return;
end if;
Result := pthread_condattr_init (Cond_Attr'Access);
@ -885,10 +865,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
if not Single_Lock then
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
Succeeded := False;
end if;
@ -1070,10 +1048,8 @@ package body System.Task_Primitives.Operations is
Result : C.int;
begin
if not Single_Lock then
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
pragma Assert (Result = 0);
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);

97
gcc/ada/libgnarl/s-taprop__mingw.adb
View file

@ -111,7 +111,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-- Used to protect All_Tasks_List
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@ -290,7 +290,7 @@ package body System.Task_Primitives.Operations is
Result_Bool := ResetEvent (HANDLE (Cond.all));
pragma Assert (Result_Bool = Win32.TRUE);
Unlock (L, Global_Lock => True);
Unlock (L);
-- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block
@ -298,7 +298,7 @@ package body System.Task_Primitives.Operations is
Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
pragma Assert (Result = 0);
Write_Lock (L, Global_Lock => True);
Write_Lock (L);
end Cond_Wait;
---------------------
@ -330,7 +330,7 @@ package body System.Task_Primitives.Operations is
Result := ResetEvent (HANDLE (Cond.all));
pragma Assert (Result = Win32.TRUE);
Unlock (L, Global_Lock => True);
Unlock (L);
-- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block.
@ -355,7 +355,7 @@ package body System.Task_Primitives.Operations is
end if;
end if;
Write_Lock (L, Global_Lock => True);
Write_Lock (L);
-- Ensure post-condition
@ -465,21 +465,14 @@ package body System.Task_Primitives.Operations is
Ceiling_Violation := False;
end Write_Lock;
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Write_Lock (L : not null access RTS_Lock) is
begin
if not Single_Lock or else Global_Lock then
EnterCriticalSection (L);
end if;
EnterCriticalSection (L);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
begin
if not Single_Lock then
EnterCriticalSection (T.Common.LL.L'Access);
end if;
EnterCriticalSection (T.Common.LL.L'Access);
end Write_Lock;
---------------
@ -501,19 +494,14 @@ package body System.Task_Primitives.Operations is
LeaveCriticalSection (L.Mutex'Access);
end Unlock;
procedure Unlock
(L : not null access RTS_Lock; Global_Lock : Boolean := False) is
procedure Unlock (L : not null access RTS_Lock) is
begin
if not Single_Lock or else Global_Lock then
LeaveCriticalSection (L);
end if;
LeaveCriticalSection (L);
end Unlock;
procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
LeaveCriticalSection (T.Common.LL.L'Access);
end if;
LeaveCriticalSection (T.Common.LL.L'Access);
end Unlock;
-----------------
@ -544,11 +532,7 @@ package body System.Task_Primitives.Operations is
begin
pragma Assert (Self_ID = Self);
if Single_Lock then
Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
if Self_ID.Deferral_Level = 0
and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
@ -599,19 +583,12 @@ package body System.Task_Primitives.Operations is
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
Cond_Timed_Wait
(Self_ID.Common.LL.CV'Access,
Single_RTS_Lock'Access,
Rel_Time, Local_Timedout, Result);
else
Cond_Timed_Wait
(Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L'Access,
Rel_Time, Local_Timedout, Result);
end if;
Cond_Timed_Wait
(Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L'Access,
Rel_Time, Local_Timedout, Result);
Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time;
if not Local_Timedout then
@ -645,10 +622,6 @@ package body System.Task_Primitives.Operations is
pragma Unreferenced (Timedout, Result);
begin
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID);
if Mode = Relative then
@ -665,19 +638,12 @@ package body System.Task_Primitives.Operations is
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
Cond_Timed_Wait
(Self_ID.Common.LL.CV'Access,
Single_RTS_Lock'Access,
Rel_Time, Timedout, Result);
else
Cond_Timed_Wait
(Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L'Access,
Rel_Time, Timedout, Result);
end if;
Cond_Timed_Wait
(Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L'Access,
Rel_Time, Timedout, Result);
Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time;
Rel_Time := Abs_Time - Check_Time;
@ -687,11 +653,6 @@ package body System.Task_Primitives.Operations is
end if;
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
Yield;
end Timed_Delay;
@ -845,10 +806,7 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.Thread := Null_Thread_Id;
Initialize_Cond (Self_ID.Common.LL.CV'Access);
if not Single_Lock then
Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
end if;
Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
Succeeded := True;
end Initialize_TCB;
@ -976,10 +934,7 @@ package body System.Task_Primitives.Operations is
pragma Unreferenced (Succeeded);
begin
if not Single_Lock then
Finalize_Lock (T.Common.LL.L'Access);
end if;
Finalize_Lock (T.Common.LL.L'Access);
Finalize_Cond (T.Common.LL.CV'Access);
if T.Known_Tasks_Index /= -1 then
@ -1035,7 +990,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@ -1044,7 +999,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
----------------

126
gcc/ada/libgnarl/s-taprop__posix.adb
View file

@ -82,7 +82,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-- Used to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
@ -443,25 +443,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Ceiling_Violation);
end Write_Lock;
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Write_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_lock (L);
pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_lock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end Write_Lock;
---------------
@ -485,24 +478,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
procedure Unlock
(L : not null access RTS_Lock; Global_Lock : Boolean := False)
is
procedure Unlock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end Unlock;
-----------------
@ -536,9 +523,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_wait
(cond => Self_ID.Common.LL.CV'Access,
mutex => (if Single_Lock
then Single_RTS_Lock'Access
else Self_ID.Common.LL.L'Access));
mutex => Self_ID.Common.LL.L'Access);
-- EINTR is not considered a failure
@ -728,48 +713,46 @@ package body System.Task_Primitives.Operations is
Next_Serial_Number := Next_Serial_Number + 1;
pragma Assert (Next_Serial_Number /= 0);
if not Single_Lock then
Result := pthread_mutexattr_init (Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
Result := pthread_mutexattr_init (Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
if Locking_Policy = 'C' then
Result :=
pthread_mutexattr_setprotocol
(Mutex_Attr'Access,
PTHREAD_PRIO_PROTECT);
pragma Assert (Result = 0);
Result :=
pthread_mutexattr_setprioceiling
(Mutex_Attr'Access,
Interfaces.C.int (System.Any_Priority'Last));
pragma Assert (Result = 0);
elsif Locking_Policy = 'I' then
Result :=
pthread_mutexattr_setprotocol
(Mutex_Attr'Access,
PTHREAD_PRIO_INHERIT);
pragma Assert (Result = 0);
end if;
if Result = 0 then
if Locking_Policy = 'C' then
Result :=
pthread_mutexattr_setprotocol
(Mutex_Attr'Access,
PTHREAD_PRIO_PROTECT);
pragma Assert (Result = 0);
Result :=
pthread_mutex_init
pthread_mutexattr_setprioceiling
(Mutex_Attr'Access,
Interfaces.C.int (System.Any_Priority'Last));
pragma Assert (Result = 0);
elsif Locking_Policy = 'I' then
Result :=
pthread_mutexattr_setprotocol
(Mutex_Attr'Access,
PTHREAD_PRIO_INHERIT);
pragma Assert (Result = 0);
end if;
Result :=
pthread_mutex_init
(Self_ID.Common.LL.L'Access,
Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
if Result /= 0 then
Succeeded := False;
return;
end if;
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
pragma Assert (Result = 0);
Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
if Result /= 0 then
Succeeded := False;
return;
end if;
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
pragma Assert (Result = 0);
Result := pthread_condattr_init (Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
@ -786,11 +769,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
if not Single_Lock then
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
Succeeded := False;
end if;
@ -915,10 +895,8 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
pragma Assert (Result = 0);
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@ -1212,7 +1190,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@ -1221,7 +1199,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------

70
gcc/ada/libgnarl/s-taprop__qnx.adb
View file

@ -82,7 +82,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-- Used to protect All_Tasks_List
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
@ -458,25 +458,18 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Write_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_lock (L);
pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_lock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end Write_Lock;
---------------
@ -500,24 +493,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
procedure Unlock
(L : not null access RTS_Lock; Global_Lock : Boolean := False)
is
procedure Unlock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end Unlock;
-----------------
@ -551,9 +538,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_cond_wait
(cond => Self_ID.Common.LL.CV'Access,
mutex => (if Single_Lock
then Single_RTS_Lock'Access
else Self_ID.Common.LL.L'Access));
mutex => Self_ID.Common.LL.L'Access);
-- EINTR is not considered a failure
@ -713,8 +698,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean)
is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@ -725,14 +709,12 @@ package body System.Task_Primitives.Operations is
Next_Serial_Number := Next_Serial_Number + 1;
pragma Assert (Next_Serial_Number /= 0);
if not Single_Lock then
Result := Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last);
pragma Assert (Result = 0);
Result := Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last);
pragma Assert (Result = 0);
if Result /= 0 then
Succeeded := False;
return;
end if;
if Result /= 0 then
Succeeded := False;
return;
end if;
Result := pthread_condattr_init (Cond_Attr'Access);
@ -751,10 +733,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
if not Single_Lock then
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
Succeeded := False;
end if;
@ -894,10 +874,8 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
pragma Assert (Result = 0);
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@ -1191,7 +1169,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@ -1200,7 +1178,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------

153
gcc/ada/libgnarl/s-taprop__solaris.adb
View file

@ -91,7 +91,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-- Used to protect All_Tasks_List
Next_Serial_Number : Task_Serial_Number := 100;
-- We start at 100, to reserve some special values for
@ -653,29 +653,22 @@ package body System.Task_Primitives.Operations is
pragma Assert (Record_Lock (Lock_Ptr (L)));
end Write_Lock;
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Write_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
Result := mutex_lock (L.L'Access);
pragma Assert (Result = 0);
pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
end if;
pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
Result := mutex_lock (L.L'Access);
pragma Assert (Result = 0);
pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
Result := mutex_lock (T.Common.LL.L.L'Access);
pragma Assert (Result = 0);
pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
end if;
pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
Result := mutex_lock (T.Common.LL.L.L'Access);
pragma Assert (Result = 0);
pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
end Write_Lock;
---------------
@ -717,27 +710,20 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Unlock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
Result := mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
end if;
pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
Result := mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
Result := mutex_unlock (T.Common.LL.L.L'Access);
pragma Assert (Result = 0);
end if;
pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
Result := mutex_unlock (T.Common.LL.L.L'Access);
pragma Assert (Result = 0);
end Unlock;
-----------------
@ -929,14 +915,12 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.Thread := Null_Thread_Id;
if not Single_Lock then
Result :=
mutex_init
(Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
Self_ID.Common.LL.L.Level :=
Private_Task_Serial_Number (Self_ID.Serial_Number);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
Result :=
mutex_init
(Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
Self_ID.Common.LL.L.Level :=
Private_Task_Serial_Number (Self_ID.Serial_Number);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
@ -946,10 +930,8 @@ package body System.Task_Primitives.Operations is
if Result = 0 then
Succeeded := True;
else
if not Single_Lock then
Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
pragma Assert (Result = 0);
end if;
Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
pragma Assert (Result = 0);
Succeeded := False;
end if;
@ -1049,10 +1031,8 @@ package body System.Task_Primitives.Operations is
begin
T.Common.LL.Thread := Null_Thread_Id;
if not Single_Lock then
Result := mutex_destroy (T.Common.LL.L.L'Access);
pragma Assert (Result = 0);
end if;
Result := mutex_destroy (T.Common.LL.L.L'Access);
pragma Assert (Result = 0);
Result := cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@ -1107,15 +1087,9 @@ package body System.Task_Primitives.Operations is
begin
pragma Assert (Check_Sleep (Reason));
if Single_Lock then
Result :=
cond_wait
(Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
else
Result :=
cond_wait
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
end if;
Result :=
cond_wait
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
pragma Assert
(Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
@ -1221,21 +1195,13 @@ package body System.Task_Primitives.Operations is
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
Result :=
cond_timedwait
(Self_ID.Common.LL.CV'Access,
Single_RTS_Lock.L'Access, Request'Access);
else
Result :=
cond_timedwait
(Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L.L'Access, Request'Access);
end if;
Result :=
cond_timedwait
(Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L.L'Access, Request'Access);
Yielded := True;
Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
if Result = 0 or Result = EINTR then
@ -1271,10 +1237,6 @@ package body System.Task_Primitives.Operations is
Yielded : Boolean := False;
begin
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID);
Abs_Time :=
@ -1291,23 +1253,14 @@ package body System.Task_Primitives.Operations is
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
Result :=
cond_timedwait
(Self_ID.Common.LL.CV'Access,
Single_RTS_Lock.L'Access,
Request'Access);
else
Result :=
cond_timedwait
(Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L.L'Access,
Request'Access);
end if;
Result :=
cond_timedwait
(Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L.L'Access,
Request'Access);
Yielded := True;
Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
pragma Assert
@ -1325,10 +1278,6 @@ package body System.Task_Primitives.Operations is
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
if not Yielded then
thr_yield;
end if;
@ -1412,10 +1361,6 @@ package body System.Task_Primitives.Operations is
return False;
end if;
if Single_Lock then
return True;
end if;
-- Check that TCB lock order rules are satisfied
P := Self_ID.Common.LL.Locks;
@ -1451,10 +1396,6 @@ package body System.Task_Primitives.Operations is
L.Owner := To_Owner_ID (To_Address (Self_ID));
if Single_Lock then
return True;
end if;
-- Check that TCB lock order rules are satisfied
P := Self_ID.Common.LL.Locks;
@ -1485,10 +1426,6 @@ package body System.Task_Primitives.Operations is
return False;
end if;
if Single_Lock then
return True;
end if;
-- Check that caller is holding own lock, on top of list
if Self_ID.Common.LL.Locks /=
@ -1528,10 +1465,6 @@ package body System.Task_Primitives.Operations is
L.Owner := To_Owner_ID (To_Address (Self_ID));
if Single_Lock then
return True;
end if;
-- Check that TCB lock order rules are satisfied
P := Self_ID.Common.LL.Locks;
@ -1880,7 +1813,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@ -1889,7 +1822,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------

109
gcc/ada/libgnarl/s-taprop__vxworks.adb
View file

@ -101,7 +101,7 @@ package body System.Task_Primitives.Operations is
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at a
-- time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-- Used to protect All_Tasks_List
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@ -374,25 +374,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Write_Lock (L : not null access RTS_Lock) is
Result : int;
begin
if not Single_Lock or else Global_Lock then
Result := semTake (L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
end if;
Result := semTake (L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
Result : int;
begin
if not Single_Lock then
Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
end if;
Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
end Write_Lock;
---------------
@ -401,8 +394,7 @@ package body System.Task_Primitives.Operations is
procedure Read_Lock
(L : not null access Lock;
Ceiling_Violation : out Boolean)
is
Ceiling_Violation : out Boolean) is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
@ -418,25 +410,18 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Unlock;
procedure Unlock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
procedure Unlock (L : not null access RTS_Lock) is
Result : int;
begin
if not Single_Lock or else Global_Lock then
Result := semGive (L.Mutex);
pragma Assert (Result = 0);
end if;
Result := semGive (L.Mutex);
pragma Assert (Result = 0);
end Unlock;
procedure Unlock (T : Task_Id) is
Result : int;
begin
if not Single_Lock then
Result := semGive (T.Common.LL.L.Mutex);
pragma Assert (Result = 0);
end if;
Result := semGive (T.Common.LL.L.Mutex);
pragma Assert (Result = 0);
end Unlock;
-----------------
@ -468,10 +453,7 @@ package body System.Task_Primitives.Operations is
-- Release the mutex before sleeping
Result :=
semGive (if Single_Lock
then Single_RTS_Lock.Mutex
else Self_ID.Common.LL.L.Mutex);
Result := semGive (Self_ID.Common.LL.L.Mutex);
pragma Assert (Result = 0);
-- Perform a blocking operation to take the CV semaphore. Note that a
@ -484,10 +466,7 @@ package body System.Task_Primitives.Operations is
-- Take the mutex back
Result :=
semTake ((if Single_Lock
then Single_RTS_Lock.Mutex
else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
end Sleep;
@ -540,10 +519,7 @@ package body System.Task_Primitives.Operations is
loop
-- Release the mutex before sleeping
Result :=
semGive (if Single_Lock
then Single_RTS_Lock.Mutex
else Self_ID.Common.LL.L.Mutex);
Result := semGive (Self_ID.Common.LL.L.Mutex);
pragma Assert (Result = 0);
-- Perform a blocking operation to take the CV semaphore. Note
@ -583,10 +559,7 @@ package body System.Task_Primitives.Operations is
-- Take the mutex back
Result :=
semTake ((if Single_Lock
then Single_RTS_Lock.Mutex
else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
exit when Timedout or Wakeup;
@ -597,16 +570,9 @@ package body System.Task_Primitives.Operations is
-- Should never hold a lock while yielding
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
Result := taskDelay (0);
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
Result := semGive (Self_ID.Common.LL.L.Mutex);
Result := taskDelay (0);
Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
end if;
Result := semGive (Self_ID.Common.LL.L.Mutex);
Result := taskDelay (0);
Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
end if;
end Timed_Sleep;
@ -653,10 +619,7 @@ package body System.Task_Primitives.Operations is
-- Modifying State, locking the TCB
Result :=
semTake ((if Single_Lock
then Single_RTS_Lock.Mutex
else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
@ -668,10 +631,7 @@ package body System.Task_Primitives.Operations is
-- Release the TCB before sleeping
Result :=
semGive (if Single_Lock
then Single_RTS_Lock.Mutex
else Self_ID.Common.LL.L.Mutex);
Result := semGive (Self_ID.Common.LL.L.Mutex);
pragma Assert (Result = 0);
exit when Aborted;
@ -697,11 +657,7 @@ package body System.Task_Primitives.Operations is
-- Take back the lock after having slept, to protect further
-- access to Self_ID.
Result :=
semTake
((if Single_Lock
then Single_RTS_Lock.Mutex
else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
pragma Assert (Result = 0);
@ -710,11 +666,7 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.State := Runnable;
Result :=
semGive
(if Single_Lock
then Single_RTS_Lock.Mutex
else Self_ID.Common.LL.L.Mutex);
Result := semGive (Self_ID.Common.LL.L.Mutex);
else
Result := taskDelay (0);
@ -875,10 +827,7 @@ package body System.Task_Primitives.Operations is
else
Succeeded := True;
if not Single_Lock then
Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
end if;
Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
end if;
end Initialize_TCB;
@ -996,10 +945,8 @@ package body System.Task_Primitives.Operations is
Result : int;
begin
if not Single_Lock then
Result := semDelete (T.Common.LL.L.Mutex);
pragma Assert (Result = 0);
end if;
Result := semDelete (T.Common.LL.L.Mutex);
pragma Assert (Result = 0);
T.Common.LL.Thread := Null_Thread_Id;
@ -1251,7 +1198,7 @@ package body System.Task_Primitives.Operations is
procedure Lock_RTS is
begin
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
@ -1260,7 +1207,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock_RTS is
begin
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------

50
gcc/ada/libgnarl/s-tarest.adb
View file

@ -62,7 +62,6 @@ package body System.Tasking.Restricted.Stages is
use Ada.Exceptions;
use Parameters;
use Task_Primitives.Operations;
Tasks_Activation_Chain : Task_Id;
@ -153,7 +152,7 @@ package body System.Tasking.Restricted.Stages is
Self_ID.Common.Global_Task_Lock_Nesting + 1;
if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
STPO.Write_Lock (Global_Task_Lock'Access);
end if;
end Task_Lock;
@ -170,7 +169,7 @@ package body System.Tasking.Restricted.Stages is
Self_ID.Common.Global_Task_Lock_Nesting - 1;
if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
STPO.Unlock (Global_Task_Lock'Access);
end if;
end Task_Unlock;
@ -265,20 +264,12 @@ package body System.Tasking.Restricted.Stages is
TH : Termination_Handler := null;
begin
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID.Common.Parent);
TH := Self_ID.Common.Parent.Common.Fall_Back_Handler;
Unlock (Self_ID.Common.Parent);
if Single_Lock then
Unlock_RTS;
end if;
-- Execute the task termination handler if we found it
if TH /= null then
@ -347,10 +338,6 @@ package body System.Tasking.Restricted.Stages is
pragma Assert (Self_ID = Environment_Task);
pragma Assert (Self_ID.Common.Wait_Count = 0);
if Single_Lock then
Lock_RTS;
end if;
-- Lock self, to prevent activated tasks from racing ahead before we
-- finish activating the chain.
@ -403,10 +390,6 @@ package body System.Tasking.Restricted.Stages is
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
end Activate_Tasks;
------------------------------------
@ -423,10 +406,6 @@ package body System.Tasking.Restricted.Stages is
Activator : constant Task_Id := Self_ID.Common.Activator;
begin
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Activator);
Write_Lock (Self_ID);
@ -449,10 +428,6 @@ package body System.Tasking.Restricted.Stages is
Unlock (Self_ID);
Unlock (Activator);
if Single_Lock then
Unlock_RTS;
end if;
-- After the activation, active priority should be the same as base
-- priority. We must unlock the Activator first, though, since it should
-- not wait if we have lower priority.
@ -533,10 +508,6 @@ package body System.Tasking.Restricted.Stages is
else System.Multiprocessors.CPU_Range (CPU));
end if;
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID);
-- With no task hierarchy, the parent of all non-Environment tasks that
@ -554,11 +525,6 @@ package body System.Tasking.Restricted.Stages is
if not Success then
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
raise Program_Error;
end if;
@ -581,10 +547,6 @@ package body System.Tasking.Restricted.Stages is
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
-- Create TSD as early as possible in the creation of a task, since
-- it may be used by the operation of Ada code within the task. If the
-- compiler has not allocated a secondary stack, a stack will be
@ -681,10 +643,6 @@ package body System.Tasking.Restricted.Stages is
begin
pragma Assert (Self_ID = STPO.Environment_Task);
if Single_Lock then
Lock_RTS;
end if;
-- Handle normal task termination by the environment task, but only for
-- the normal task termination. In the case of Abnormal and
-- Unhandled_Exception they must have been handled before, and the task
@ -705,10 +663,6 @@ package body System.Tasking.Restricted.Stages is
Sleep (Self_ID, Master_Completion_Sleep);
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
-- Should never return from Master Completion Sleep
raise Program_Error;

15
gcc/ada/libgnarl/s-tasini.adb
View file

@ -44,7 +44,6 @@ with System.Soft_Links;
with System.Soft_Links.Tasking;
with System.Tasking.Debug;
with System.Tasking.Task_Attributes;
with System.Parameters;
with System.Secondary_Stack;
pragma Elaborate_All (System.Secondary_Stack);
@ -244,18 +243,10 @@ package body System.Tasking.Initialization is
Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID);
Self_ID.Pending_Action := False;
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
-- Restore the original Deferral value
Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1;
@ -309,7 +300,7 @@ package body System.Tasking.Initialization is
procedure Final_Task_Unlock (Self_ID : Task_Id) is
begin
pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting = 1);
Unlock (Global_Task_Lock'Access, Global_Lock => True);
Unlock (Global_Task_Lock'Access);
end Final_Task_Unlock;
--------------
@ -563,7 +554,7 @@ package body System.Tasking.Initialization is
if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
Defer_Abort_Nestable (Self_ID);
Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
Write_Lock (Global_Task_Lock'Access);
end if;
end Task_Lock;
@ -593,7 +584,7 @@ package body System.Tasking.Initialization is
Self_ID.Common.Global_Task_Lock_Nesting - 1;
if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
Unlock (Global_Task_Lock'Access, Global_Lock => True);
Unlock (Global_Task_Lock'Access);
Undefer_Abort_Nestable (Self_ID);
end if;
end Task_Unlock;

13
gcc/ada/libgnarl/s-tasque.adb
View file

@ -35,11 +35,9 @@
with System.Task_Primitives.Operations;
with System.Tasking.Initialization;
with System.Parameters;
package body System.Tasking.Queuing is
use Parameters;
use Task_Primitives.Operations;
use Protected_Objects;
use Protected_Objects.Entries;
@ -68,15 +66,10 @@ package body System.Tasking.Queuing is
procedure Broadcast_Program_Error
(Self_ID : Task_Id;
Object : Protection_Entries_Access;
Pending_Call : Entry_Call_Link;
RTS_Locked : Boolean := False)
Pending_Call : Entry_Call_Link)
is
Entry_Call : Entry_Call_Link;
begin
if Single_Lock and then not RTS_Locked then
Lock_RTS;
end if;
if Pending_Call /= null then
Send_Program_Error (Self_ID, Pending_Call);
end if;
@ -91,10 +84,6 @@ package body System.Tasking.Queuing is
Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
end loop;
end loop;
if Single_Lock and then not RTS_Locked then
Unlock_RTS;
end if;
end Broadcast_Program_Error;
-----------------

5
gcc/ada/libgnarl/s-tasque.ads
View file

@ -38,13 +38,10 @@ package System.Tasking.Queuing is
procedure Broadcast_Program_Error
(Self_ID : Task_Id;
Object : POE.Protection_Entries_Access;
Pending_Call : Entry_Call_Link;
RTS_Locked : Boolean := False);
Pending_Call : Entry_Call_Link);
-- Raise Program_Error in all tasks calling the protected entries of Object
-- The exception will not be raised immediately for the calling task; it
-- will be deferred until it calls Check_Exception.
-- RTS_Locked indicates whether the global RTS lock is taken (only
-- relevant if Single_Lock is True).
procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link);
-- Enqueue Call at the end of entry_queue E

197
gcc/ada/libgnarl/s-tasren.adb
View file

@ -37,7 +37,6 @@ with System.Tasking.Utilities;
with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Debug;
with System.Restrictions;
with System.Parameters;
package body System.Tasking.Rendezvous is
@ -45,7 +44,6 @@ package body System.Tasking.Rendezvous is
package POO renames Protected_Objects.Operations;
package POE renames Protected_Objects.Entries;
use Parameters;
use Task_Primitives.Operations;
type Select_Treatment is (
@ -155,11 +153,6 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort (Self_Id);
if Single_Lock then
Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
@ -168,11 +161,6 @@ package body System.Tasking.Rendezvous is
pragma Assert (Self_Id.Pending_Action);
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
@ -221,13 +209,7 @@ package body System.Tasking.Rendezvous is
-- return, we will start the rendezvous.
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
end Accept_Call;
--------------------
@ -242,11 +224,6 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort_Nestable (Self_Id);
if Single_Lock then
Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
@ -255,11 +232,6 @@ package body System.Tasking.Rendezvous is
pragma Assert (Self_Id.Pending_Action);
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort_Nestable (Self_Id);
-- Should never get here ???
@ -303,10 +275,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Caller);
end if;
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort_Nestable (Self_Id);
end Accept_Trivial;
@ -401,20 +369,12 @@ package body System.Tasking.Rendezvous is
-- Note: the caller will undefer abort on return (see WARNING above)
if Single_Lock then
Lock_RTS;
end if;
if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
STPO.Write_Lock (Self_Id);
Utilities.Exit_One_ATC_Level (Self_Id);
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Local_Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
@ -426,11 +386,6 @@ package body System.Tasking.Rendezvous is
(Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
Rendezvous_Successful := Entry_Call.State = Done;
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Local_Undefer_Abort (Self_Id);
Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Call_Synchronous;
@ -445,20 +400,11 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort_Nestable (Self_Id);
if Single_Lock then
Lock_RTS;
end if;
STPO.Write_Lock (T);
Result := T.Callable;
STPO.Unlock (T);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort_Nestable (Self_Id);
return Result;
end Callable;
@ -545,10 +491,6 @@ package body System.Tasking.Rendezvous is
-- it was aborted.
if Ex = Standard'Abort_Signal'Identity then
if Single_Lock then
Lock_RTS;
end if;
while Entry_Call /= null loop
Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
@ -568,11 +510,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Caller);
Entry_Call := Entry_Call.Acceptor_Prev_Call;
end loop;
if Single_Lock then
Unlock_RTS;
end if;
else
Caller := Entry_Call.Self;
@ -588,23 +525,10 @@ package body System.Tasking.Rendezvous is
-- Requeue to another task entry
if Single_Lock then
Lock_RTS;
end if;
if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
if Single_Lock then
Unlock_RTS;
end if;
else
-- Requeue to a protected entry
@ -614,20 +538,11 @@ package body System.Tasking.Rendezvous is
if Ceiling_Violation then
pragma Assert (Ex = Ada.Exceptions.Null_Id);
Entry_Call.Exception_To_Raise := Program_Error'Identity;
if Single_Lock then
Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Initialization.Wakeup_Entry_Caller
(Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
if Single_Lock then
Unlock_RTS;
end if;
else
POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
POO.PO_Service_Entries (Self_Id, Called_PO);
@ -642,11 +557,6 @@ package body System.Tasking.Rendezvous is
Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
Entry_Call.Exception_To_Raise := Ex;
if Single_Lock then
Lock_RTS;
end if;
STPO.Write_Lock (Caller);
-- Done with Caller locked to make sure that Wakeup is not lost
@ -661,11 +571,6 @@ package body System.Tasking.Rendezvous is
Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
STPO.Unlock (Caller);
if Single_Lock then
Unlock_RTS;
end if;
Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
end if;
end if;
@ -733,11 +638,6 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort (Self_Id);
if Single_Lock then
Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
@ -747,10 +647,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
-- ??? In some cases abort is deferred more than once. Need to
-- figure out why this happens.
@ -902,10 +798,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Index := Self_Id.Chosen_Index;
Initialization.Undefer_Abort_Nestable (Self_Id);
@ -961,21 +853,11 @@ package body System.Tasking.Rendezvous is
else
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
raise Program_Error with
"entry call not a delay mode";
raise Program_Error with "entry call not a delay mode";
end if;
end case;
if Single_Lock then
Unlock_RTS;
end if;
-- Caller has been chosen
-- Self_Id.Common.Call should already be updated by the Caller.
@ -1018,19 +900,9 @@ package body System.Tasking.Rendezvous is
begin
Initialization.Defer_Abort (Self_Id);
if Single_Lock then
Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
return Return_Count;
@ -1306,19 +1178,10 @@ package body System.Tasking.Rendezvous is
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
Entry_Call.With_Abort := True;
if Single_Lock then
Lock_RTS;
end if;
if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
STPO.Write_Lock (Self_Id);
Utilities.Exit_One_ATC_Level (Self_Id);
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
@ -1335,10 +1198,6 @@ package body System.Tasking.Rendezvous is
Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
end if;
if Single_Lock then
Unlock_RTS;
end if;
-- Note: following assignment needs to be atomic
Rendezvous_Successful := Entry_Call.State = Done;
@ -1392,10 +1251,6 @@ package body System.Tasking.Rendezvous is
-- If we are aborted here, the effect will be pending
if Single_Lock then
Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
if not Self_Id.Callable then
@ -1404,11 +1259,6 @@ package body System.Tasking.Rendezvous is
pragma Assert (Self_Id.Pending_Action);
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
-- Should never get here ???
@ -1484,21 +1334,13 @@ package body System.Tasking.Rendezvous is
-- caller a chance of getting ready immediately, using Unlock
-- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
if Single_Lock then
Unlock_RTS;
else
Unlock (Self_Id);
end if;
Unlock (Self_Id);
if Self_Id.Open_Accepts /= null then
Yield;
end if;
if Single_Lock then
Lock_RTS;
else
Write_Lock (Self_Id);
end if;
Write_Lock (Self_Id);
-- Check if this task has been aborted while the lock was released
@ -1574,10 +1416,6 @@ package body System.Tasking.Rendezvous is
null;
end case;
if Single_Lock then
Unlock_RTS;
end if;
if not Yielded then
Yield;
end if;
@ -1657,19 +1495,10 @@ package body System.Tasking.Rendezvous is
-- Note: the caller will undefer abort on return (see WARNING above)
if Single_Lock then
Lock_RTS;
end if;
if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
STPO.Write_Lock (Self_Id);
Utilities.Exit_One_ATC_Level (Self_Id);
STPO.Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
raise Tasking_Error;
@ -1680,10 +1509,6 @@ package body System.Tasking.Rendezvous is
(Entry_Call, Timeout, Mode, Yielded);
Unlock (Self_Id);
if Single_Lock then
Unlock_RTS;
end if;
-- ??? Do we need to yield in case Yielded is False
Rendezvous_Successful := Entry_Call.State = Done;
@ -1703,21 +1528,13 @@ package body System.Tasking.Rendezvous is
-- a chance of getting ready immediately, using Unlock & Yield.
-- See similar action in Wait_For_Completion & Timed_Selective_Wait.
if Single_Lock then
Unlock_RTS;
else
Unlock (Self_Id);
end if;
Unlock (Self_Id);
if Self_Id.Open_Accepts /= null then
Yield;
end if;
if Single_Lock then
Lock_RTS;
else
Write_Lock (Self_Id);
end if;
Write_Lock (Self_Id);
-- Check if this task has been aborted while the lock was released

3
gcc/ada/libgnarl/s-tasren.ads
View file

@ -317,8 +317,7 @@ package System.Tasking.Rendezvous is
function Task_Do_Or_Queue
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link) return Boolean;
-- Call this only with abort deferred and holding no locks, except
-- the global RTS lock when Single_Lock is True which must be owned.
-- Call this only with abort deferred and holding no locks.
-- Returns False iff the call cannot be served or queued, as is the
-- case if the caller is not callable; i.e., a False return value
-- indicates that Tasking_Error should be raised.

130
gcc/ada/libgnarl/s-tassta.adb
View file

@ -74,7 +74,6 @@ package body System.Tasking.Stages is
use Ada.Exceptions;
use Parameters;
use Secondary_Stack;
use Task_Primitives;
use Task_Primitives.Operations;
@ -341,9 +340,7 @@ package body System.Tasking.Stages is
C := C.Common.Activation_Link;
end loop;
if not Single_Lock then
Unlock_RTS;
end if;
Unlock_RTS;
-- Close the entries of any tasks that failed thread creation, and count
-- those that have not finished activation.
@ -382,10 +379,6 @@ package body System.Tasking.Stages is
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
-- Remove the tasks from the chain
Chain_Access.T_ID := null;
@ -406,17 +399,7 @@ package body System.Tasking.Stages is
begin
Initialization.Defer_Abort_Nestable (Self_ID);
if Single_Lock then
Lock_RTS;
end if;
Vulnerable_Complete_Activation (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort_Nestable (Self_ID);
-- ??? Why do we need to allow for nested deferral here?
@ -846,12 +829,8 @@ package body System.Tasking.Stages is
-- Force termination of "independent" library-level server tasks
Lock_RTS;
Abort_Dependents (Self_ID);
if not Single_Lock then
Unlock_RTS;
end if;
Unlock_RTS;
-- We need to explicitly wait for the task to be terminated here
-- because on true concurrent system, we may end this procedure before
@ -891,10 +870,6 @@ package body System.Tasking.Stages is
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
-- Complete the environment task
Vulnerable_Complete_Task (Self_ID);
@ -1294,10 +1269,6 @@ package body System.Tasking.Stages is
-- the environment task. The task termination code for the environment
-- task is executed by SSL.Task_Termination_Handler.
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID);
if Self_ID.Common.Specific_Handler /= null then
@ -1320,10 +1291,6 @@ package body System.Tasking.Stages is
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
-- Execute the task termination handler if we found it
if TH /= null then
@ -1393,26 +1360,16 @@ package body System.Tasking.Stages is
Initialization.Task_Lock (Self_ID);
if Single_Lock then
Lock_RTS;
end if;
Master_Of_Task := Self_ID.Master_Of_Task;
-- Check if the current task is an independent task If so, decrement
-- the Independent_Task_Count value.
if Master_Of_Task = Independent_Task_Level then
if Single_Lock then
Utilities.Independent_Task_Count :=
Utilities.Independent_Task_Count - 1;
else
Write_Lock (Environment_Task);
Utilities.Independent_Task_Count :=
Utilities.Independent_Task_Count - 1;
Unlock (Environment_Task);
end if;
Write_Lock (Environment_Task);
Utilities.Independent_Task_Count :=
Utilities.Independent_Task_Count - 1;
Unlock (Environment_Task);
end if;
-- Unprotect the guard page if needed
@ -1422,10 +1379,6 @@ package body System.Tasking.Stages is
Utilities.Make_Passive (Self_ID, Task_Completed => True);
Deallocate := Self_ID.Free_On_Termination;
if Single_Lock then
Unlock_RTS;
end if;
pragma Assert (Check_Exit (Self_ID));
SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
@ -1454,20 +1407,11 @@ package body System.Tasking.Stages is
begin
Initialization.Defer_Abort_Nestable (Self_ID);
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (T);
Result := T.Common.State = Terminated;
Unlock (T);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort_Nestable (Self_ID);
return Result;
end Terminated;
@ -1600,10 +1544,7 @@ package body System.Tasking.Stages is
function Check_Unactivated_Tasks return Boolean is
begin
if not Single_Lock then
Lock_RTS;
end if;
Lock_RTS;
Write_Lock (Self_ID);
C := All_Tasks_List;
@ -1626,10 +1567,7 @@ package body System.Tasking.Stages is
end loop;
Unlock (Self_ID);
if not Single_Lock then
Unlock_RTS;
end if;
Unlock_RTS;
return True;
end Check_Unactivated_Tasks;
@ -1698,10 +1636,7 @@ package body System.Tasking.Stages is
Self_ID.Common.State := Master_Completion_Sleep;
Unlock (Self_ID);
if not Single_Lock then
Unlock_RTS;
end if;
Unlock_RTS;
-- Wait until dependent tasks are all terminated or ready to terminate.
-- While waiting, the task may be awakened if the task's priority needs
@ -1718,15 +1653,11 @@ package body System.Tasking.Stages is
if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
and then not Self_ID.Dependents_Aborted
then
if Single_Lock then
Abort_Dependents (Self_ID);
else
Unlock (Self_ID);
Lock_RTS;
Abort_Dependents (Self_ID);
Unlock_RTS;
Write_Lock (Self_ID);
end if;
Unlock (Self_ID);
Lock_RTS;
Abort_Dependents (Self_ID);
Unlock_RTS;
Write_Lock (Self_ID);
else
pragma Debug
(Debug.Trace (Self_ID, "master_completion_sleep", 'C'));
@ -1753,10 +1684,7 @@ package body System.Tasking.Stages is
-- Force any remaining dependents to terminate by aborting them
if not Single_Lock then
Lock_RTS;
end if;
Lock_RTS;
Abort_Dependents (Self_ID);
-- Above, when we "abort" the dependents we are simply using this
@ -1801,10 +1729,7 @@ package body System.Tasking.Stages is
Self_ID.Common.State := Master_Phase_2_Sleep;
Unlock (Self_ID);
if not Single_Lock then
Unlock_RTS;
end if;
Unlock_RTS;
-- Wait for all counted tasks to finish terminating themselves
@ -1828,10 +1753,7 @@ package body System.Tasking.Stages is
-- locks. Instead, we put those ATCBs to be freed onto a temporary list,
-- called To_Be_Freed.
if not Single_Lock then
Lock_RTS;
end if;
Lock_RTS;
C := All_Tasks_List;
P := null;
while C /= null loop
@ -1986,10 +1908,6 @@ package body System.Tasking.Stages is
pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID);
Self_ID.Callable := False;
@ -2005,10 +1923,6 @@ package body System.Tasking.Stages is
Vulnerable_Complete_Activation (Self_ID);
end if;
if Single_Lock then
Unlock_RTS;
end if;
-- If Self_ID.Master_Within = Self_ID.Master_Of_Task + 2 we may have
-- dependent tasks for which we need to wait. Otherwise we just exit.
@ -2035,18 +1949,10 @@ package body System.Tasking.Stages is
begin
pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (T);
Initialization.Finalize_Attributes (T);
Unlock (T);
if Single_Lock then
Unlock_RTS;
end if;
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;

14
gcc/ada/libgnarl/s-tasuti.adb
View file

@ -41,13 +41,11 @@ with System.Tasking.Debug;
with System.Task_Primitives.Operations;
with System.Tasking.Initialization;
with System.Tasking.Queuing;
with System.Parameters;
package body System.Tasking.Utilities is
package STPO renames System.Task_Primitives.Operations;
use Parameters;
use Tasking.Debug;
use Task_Primitives;
use Task_Primitives.Operations;
@ -58,7 +56,7 @@ package body System.Tasking.Utilities is
-- Similar to Locked_Abort_To_Level (Self_ID, T, Level_Completed_Task),
-- but:
-- (1) caller should be holding no locks except RTS_Lock when Single_Lock
-- (1) caller should be holding no locks
-- (2) may be called for tasks that have not yet been activated
-- (3) always aborts whole task
@ -248,11 +246,6 @@ package body System.Tasking.Utilities is
end if;
Initialization.Defer_Abort (Self_Id);
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Environment_Task);
Write_Lock (Self_Id);
@ -277,11 +270,6 @@ package body System.Tasking.Utilities is
pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep);
Unlock (Environment_Task);
if Single_Lock then
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
-- Return True. Actually the return value is junk, since we expect it

5
gcc/ada/libgnarl/s-tasuti.ads
View file

@ -102,7 +102,7 @@ package System.Tasking.Utilities is
procedure Cancel_Queued_Entry_Calls (T : Task_Id);
-- Cancel any entry calls queued on target task.
-- Call this while holding T's lock (or RTS_Lock in Single_Lock mode).
-- Call this while holding T's lock.
procedure Exit_One_ATC_Level (Self_ID : Task_Id);
pragma Inline (Exit_One_ATC_Level);
@ -124,7 +124,6 @@ package System.Tasking.Utilities is
procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean);
-- Update counts to indicate current task is either terminated or
-- accepting on a terminate alternative. Call holding no locks except
-- Global_Task_Lock when calling from Terminate_Task, and RTS_Lock when
-- Single_Lock is True.
-- Global_Task_Lock when calling from Terminate_Task.
end System.Tasking.Utilities;

21
gcc/ada/libgnarl/s-tpoben.adb
View file

@ -43,7 +43,6 @@
with System.Task_Primitives.Operations;
with System.Restrictions;
with System.Parameters;
with System.Tasking.Initialization;
pragma Elaborate_All (System.Tasking.Initialization);
@ -53,7 +52,6 @@ package body System.Tasking.Protected_Objects.Entries is
package STPO renames System.Task_Primitives.Operations;
use Parameters;
use Task_Primitives.Operations;
----------------
@ -81,10 +79,6 @@ package body System.Tasking.Protected_Objects.Entries is
STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
if Single_Lock then
Lock_RTS;
end if;
if Ceiling_Violation then
-- Dip our own priority down to ceiling of lock. See similar code in
@ -95,21 +89,12 @@ package body System.Tasking.Protected_Objects.Entries is
Self_ID.New_Base_Priority := Object.Ceiling;
Initialization.Change_Base_Priority (Self_ID);
STPO.Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
if Ceiling_Violation then
raise Program_Error with "ceiling violation";
end if;
if Single_Lock then
Lock_RTS;
end if;
Object.Old_Base_Priority := Old_Base_Priority;
Object.Pending_Action := True;
end if;
@ -133,13 +118,7 @@ package body System.Tasking.Protected_Objects.Entries is
end loop;
Object.Finalized := True;
if Single_Lock then
Unlock_RTS;
end if;
STPO.Unlock (Object.L'Unrestricted_Access);
STPO.Finalize_Lock (Object.L'Unrestricted_Access);
end Finalize;

119
gcc/ada/libgnarl/s-tpobop.adb
View file

@ -48,7 +48,6 @@ with System.Tasking.Queuing;
with System.Tasking.Rendezvous;
with System.Tasking.Utilities;
with System.Tasking.Debug;
with System.Parameters;
with System.Restrictions;
with System.Tasking.Initialization;
@ -59,7 +58,6 @@ package body System.Tasking.Protected_Objects.Operations is
package STPO renames System.Task_Primitives.Operations;
use Parameters;
use Ada.Exceptions;
use Entries;
@ -313,19 +311,10 @@ package body System.Tasking.Protected_Objects.Operations is
-- Body of current entry served call to completion
Object.Call_In_Progress := null;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
Requeue_Call (Self_ID, Object, Entry_Call);
end if;
@ -353,19 +342,10 @@ package body System.Tasking.Protected_Objects.Operations is
-- Max_Queue_Length bound, raise Program_Error.
Entry_Call.Exception_To_Raise := Program_Error'Identity;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
return;
end if;
end if;
@ -379,18 +359,10 @@ package body System.Tasking.Protected_Objects.Operations is
else
-- Conditional_Call and With_Abort
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
pragma Assert (Entry_Call.State /= Not_Yet_Abortable);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
exception
@ -437,8 +409,7 @@ package body System.Tasking.Protected_Objects.Operations is
exception
when others =>
Queuing.Broadcast_Program_Error
(Self_ID, Object, Entry_Call);
Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
end;
if Object.Call_In_Progress = null then
@ -448,18 +419,9 @@ package body System.Tasking.Protected_Objects.Operations is
else
Object.Call_In_Progress := null;
Caller := Entry_Call.Self;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Caller);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
end loop;
@ -608,18 +570,10 @@ package body System.Tasking.Protected_Objects.Operations is
-- Once State >= Done it will not change any more
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_ID);
Utilities.Exit_One_ATC_Level (Self_ID);
STPO.Unlock (Self_ID);
if Single_Lock then
STPO.Unlock_RTS;
end if;
Block.Enqueued := False;
Block.Cancelled := Entry_Call.State = Cancelled;
Initialization.Undefer_Abort_Nestable (Self_ID);
@ -640,13 +594,7 @@ package body System.Tasking.Protected_Objects.Operations is
-- Try to avoid an expensive call
if not Initially_Abortable then
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
STPO.Unlock_RTS;
else
Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
end if;
Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
end if;
else
@ -654,16 +602,9 @@ package body System.Tasking.Protected_Objects.Operations is
when Conditional_Call
| Simple_Call
=>
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock_RTS;
else
STPO.Write_Lock (Self_ID);
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock (Self_ID);
end if;
STPO.Write_Lock (Self_ID);
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock (Self_ID);
Block.Cancelled := Entry_Call.State = Cancelled;
@ -700,21 +641,11 @@ package body System.Tasking.Protected_Objects.Operations is
-- Call is to be requeued to a task entry
if Single_Lock then
STPO.Lock_RTS;
end if;
Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call);
if not Result then
Queuing.Broadcast_Program_Error
(Self_Id, Object, Entry_Call, RTS_Locked => True);
Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call);
end if;
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
-- Call should be requeued to a PO
@ -767,19 +698,11 @@ package body System.Tasking.Protected_Objects.Operations is
Entry_Call.Exception_To_Raise := Program_Error'Identity;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
Initialization.Wakeup_Entry_Caller
(Self_Id, Entry_Call, Done);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
Queuing.Enqueue
(New_Object.Entry_Queues (E), Entry_Call);
@ -993,23 +916,13 @@ package body System.Tasking.Protected_Objects.Operations is
PO_Do_Or_Queue (Self_Id, Object, Entry_Call);
PO_Service_Entries (Self_Id, Object);
if Single_Lock then
STPO.Lock_RTS;
else
STPO.Write_Lock (Self_Id);
end if;
STPO.Write_Lock (Self_Id);
-- Try to avoid waiting for completed or cancelled calls
if Entry_Call.State >= Done then
Utilities.Exit_One_ATC_Level (Self_Id);
if Single_Lock then
STPO.Unlock_RTS;
else
STPO.Unlock (Self_Id);
end if;
STPO.Unlock (Self_Id);
Entry_Call_Successful := Entry_Call.State = Done;
Initialization.Undefer_Abort_Nestable (Self_Id);
@ -1019,12 +932,7 @@ package body System.Tasking.Protected_Objects.Operations is
Entry_Calls.Wait_For_Completion_With_Timeout
(Entry_Call, Timeout, Mode, Yielded);
if Single_Lock then
STPO.Unlock_RTS;
else
STPO.Unlock (Self_Id);
end if;
STPO.Unlock (Self_Id);
-- ??? Do we need to yield in case Yielded is False
@ -1075,10 +983,6 @@ package body System.Tasking.Protected_Objects.Operations is
if Old < Was_Abortable and then
Entry_Call.State = Now_Abortable
then
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
if Entry_Call.Self.Common.State = Async_Select_Sleep then
@ -1086,11 +990,6 @@ package body System.Tasking.Protected_Objects.Operations is
end if;
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
elsif Entry_Call.Mode = Conditional_Call then

17
gcc/ada/libgnarl/s-tpopmo.adb
View file

@ -193,9 +193,7 @@ package body Monotonic is
Result :=
pthread_cond_timedwait
(cond => Self_ID.Common.LL.CV'Access,
mutex => (if Single_Lock
then Single_RTS_Lock'Access
else Self_ID.Common.LL.L'Access),
mutex => Self_ID.Common.LL.L'Access,
abstime => Request'Access);
case Result is
@ -244,10 +242,6 @@ package body Monotonic is
Exit_Outer : Boolean := False;
begin
if Single_Lock then
Lock_RTS;
end if;
Write_Lock (Self_ID);
Compute_Deadline
@ -286,9 +280,7 @@ package body Monotonic is
Result :=
pthread_cond_timedwait
(cond => Self_ID.Common.LL.CV'Access,
mutex => (if Single_Lock
then Single_RTS_Lock'Access
else Self_ID.Common.LL.L'Access),
mutex => Self_ID.Common.LL.L'Access,
abstime => Request'Access);
case Result is
@ -314,11 +306,6 @@ package body Monotonic is
end if;
Unlock (Self_ID);
if Single_Lock then
Unlock_RTS;
end if;
pragma Unreferenced (Result);
Result := sched_yield;
end Timed_Delay;

36
gcc/ada/libgnarl/s-tposen.adb
View file

@ -62,14 +62,11 @@ pragma Suppress (All_Checks);
with Ada.Exceptions;
with System.Task_Primitives.Operations;
with System.Parameters;
package body System.Tasking.Protected_Objects.Single_Entry is
package STPO renames System.Task_Primitives.Operations;
use Parameters;
-----------------------
-- Local Subprograms --
-----------------------
@ -143,18 +140,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is
begin
Entry_Call.Exception_To_Raise := Program_Error'Identity;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Caller);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end Send_Program_Error;
-------------------------
@ -286,18 +274,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is
(Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
Object.Call_In_Progress := null;
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
pragma Assert (Entry_Call.Mode = Simple_Call);
@ -370,17 +350,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is
pragma Assert (Entry_Call.State /= Cancelled);
if Entry_Call.State /= Done then
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
Wait_For_Completion (Entry_Call'Access);
STPO.Unlock (Self_Id);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
Check_Exception (Self_Id, Entry_Call'Access);
@ -427,18 +399,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Caller := Entry_Call.Self;
Unlock_Entry (Object);
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Caller);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Caller);
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
-- Just unlock the entry

13
gcc/ada/libgnat/s-parame.ads
View file

@ -147,19 +147,6 @@ package System.Parameters is
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
----------------------
Single_Lock : constant Boolean := False;
-- Indicates whether a single lock should be used within the tasking
-- run-time to protect internal structures. If True, a single lock
-- will be used, meaning less locking/unlocking operations, but also
-- more global contention. In general, Single_Lock should be set to
-- True on single processor machines, and to False to multi-processor
-- systems, but this can vary from application to application and also
-- depends on the scheduling policy.
-------------------
-- Task Abortion --
-------------------

13
gcc/ada/libgnat/s-parame__ae653.ads
View file

@ -147,19 +147,6 @@ package System.Parameters is
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
----------------------
Single_Lock : constant Boolean := False;
-- Indicates whether a single lock should be used within the tasking
-- run-time to protect internal structures. If True, a single lock
-- will be used, meaning less locking/unlocking operations, but also
-- more global contention. In general, Single_Lock should be set to
-- True on single processor machines, and to False to multi-processor
-- systems, but this can vary from application to application and also
-- depends on the scheduling policy.
-------------------
-- Task Abortion --
-------------------

13
gcc/ada/libgnat/s-parame__hpux.ads
View file

@ -145,19 +145,6 @@ package System.Parameters is
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
----------------------
Single_Lock : constant Boolean := False;
-- Indicates whether a single lock should be used within the tasking
-- run-time to protect internal structures. If True, a single lock
-- will be used, meaning less locking/unlocking operations, but also
-- more global contention. In general, Single_Lock should be set to
-- True on single processor machines, and to False to multi-processor
-- systems, but this can vary from application to application and also
-- depends on the scheduling policy.
-------------------
-- Task Abortion --
-------------------

13
gcc/ada/libgnat/s-parame__vxworks.ads
View file

@ -147,19 +147,6 @@ package System.Parameters is
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
----------------------
Single_Lock : constant Boolean := False;
-- Indicates whether a single lock should be used within the tasking
-- run-time to protect internal structures. If True, a single lock
-- will be used, meaning less locking/unlocking operations, but also
-- more global contention. In general, Single_Lock should be set to
-- True on single processor machines, and to False to multi-processor
-- systems, but this can vary from application to application and also
-- depends on the scheduling policy.
-------------------
-- Task Abortion --
-------------------