with System.Task_Primitives.Operations;
with System.Tasking;
-with System.Parameters;
with System.Soft_Links;
with Ada.Unchecked_Conversion;
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
- use System.Parameters;
use System.Tasking;
function Convert_Ids is new
SSL.Abort_Defer.all;
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
STPO.Write_Lock (Target);
Target.Common.Base_Priority := Priority;
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
------------------------------------------------------------------------------
with System.Address_Image;
-with System.Parameters;
with System.Soft_Links;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
package body Ada.Task_Identification with
SPARK_Mode => Off
is
-
- use System.Parameters;
-
package STPO renames System.Task_Primitives.Operations;
-----------------------
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;
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;
with System.Tasking;
with System.Task_Primitives.Operations;
-with System.Parameters;
with System.Soft_Links;
with Ada.Unchecked_Conversion;
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
- use System.Parameters;
-
-----------------------
-- Local subprograms --
-----------------------
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;
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;
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;
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
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.
-- 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
-- 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
-- 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
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
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
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;
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
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);
-- 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;
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;
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
end if;
STPO.Unlock (Timer_Server_ID);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end Time_Enqueue;
---------------
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
-- 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;
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;
-- 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;
-- 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);
-- ???
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;
(Current_Task);
STPO.Unlock (Current_Task);
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
-- Following lock should not fail
Lock_Entries (Test_PO);
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
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;
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
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;
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;
-- 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);
Self_Id.Common.State := Runnable;
Utilities.Exit_One_ATC_Level (Self_Id);
-
end Wait_For_Completion;
--------------------------------------
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);
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
-- 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
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
--
-- 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
-- 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
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
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;
---------------
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;
-----------------
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
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;
pragma Warnings (Off, Result);
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
Abs_Time :=
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;
end if;
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Result := sched_yield;
end Timed_Delay;
Cond_Attr : aliased pthread_condattr_t;
begin
- if not Single_Lock then
- 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);
- end if;
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
+ 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;
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
+ 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);
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;
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);
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
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
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
-----------------
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;
---------------
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;
-----------------
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
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);
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;
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);
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");
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
Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
pragma Assert (Result = 0);
- Write_Lock (L, Global_Lock => True);
+ Write_Lock (L);
end Cond_Wait;
---------------------
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.
end if;
end if;
- Write_Lock (L, Global_Lock => True);
+ Write_Lock (L);
-- Ensure post-condition
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;
---------------
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;
-----------------
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
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
pragma Unreferenced (Timedout, Result);
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
if Mode = Relative then
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;
end if;
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Yield;
end Timed_Delay;
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;
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
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
----------------
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
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;
---------------
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;
-----------------
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
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);
-
- 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_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
- Result :=
- pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access,
- Interfaces.C.int (System.Any_Priority'Last));
- pragma Assert (Result = 0);
+ if Result = 0 then
+ if Locking_Policy = 'C' then
+ Result :=
+ pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access,
+ PTHREAD_PRIO_PROTECT);
+ 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_mutexattr_setprioceiling
+ (Mutex_Attr'Access,
+ Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+ elsif Locking_Policy = 'I' then
Result :=
- pthread_mutex_init
- (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access,
+ PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
end if;
- if Result /= 0 then
- Succeeded := False;
- return;
- 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;
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
+ 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);
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;
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);
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
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
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;
---------------
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;
-----------------
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
-- 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;
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);
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;
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);
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
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
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;
---------------
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;
-----------------
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);
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;
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);
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));
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
Yielded : Boolean := False;
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
Abs_Time :=
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
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
if not Yielded then
thr_yield;
end if;
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;
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;
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 /=
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;
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
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");
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;
---------------
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;
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;
-----------------
-- 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
-- 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;
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
-- 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;
-- 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;
-- 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);
-- 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;
-- 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);
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);
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;
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;
procedure Lock_RTS is
begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ Write_Lock (Single_RTS_Lock'Access);
end Lock_RTS;
----------------
procedure Unlock_RTS is
begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ Unlock (Single_RTS_Lock'Access);
end Unlock_RTS;
------------------
use Ada.Exceptions;
- use Parameters;
use Task_Primitives.Operations;
Tasks_Activation_Chain : Task_Id;
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;
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;
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
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.
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
end Activate_Tasks;
------------------------------------
Activator : constant Task_Id := Self_ID.Common.Activator;
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Activator);
Write_Lock (Self_ID);
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.
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
if not Success then
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
raise Program_Error;
end if;
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
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
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;
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);
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;
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;
--------------
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;
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;
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;
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;
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;
-----------------
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
with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Debug;
with System.Restrictions;
-with System.Parameters;
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 (
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
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 ???
-- 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;
--------------------
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
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 ???
STPO.Unlock (Caller);
end if;
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Initialization.Undefer_Abort_Nestable (Self_Id);
end Accept_Trivial;
-- 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;
(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;
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;
-- 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;
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;
-- 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
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);
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
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;
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
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.
STPO.Unlock (Self_Id);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
Index := Self_Id.Chosen_Index;
Initialization.Undefer_Abort_Nestable (Self_Id);
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.
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;
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;
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;
-- 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
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 ???
-- 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
null;
end case;
- if Single_Lock then
- Unlock_RTS;
- end if;
-
if not Yielded then
Yield;
end if;
-- 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;
(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;
-- 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
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.
use Ada.Exceptions;
- use Parameters;
use Secondary_Stack;
use Task_Primitives;
use Task_Primitives.Operations;
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.
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;
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?
-- 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
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Complete the environment task
Vulnerable_Complete_Task (Self_ID);
-- 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
Unlock (Self_ID);
- if Single_Lock then
- Unlock_RTS;
- end if;
-
-- Execute the task termination handler if we found it
if TH /= null then
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
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);
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;
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;
end loop;
Unlock (Self_ID);
-
- if not Single_Lock then
- Unlock_RTS;
- end if;
+ Unlock_RTS;
return True;
end Check_Unactivated_Tasks;
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
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'));
-- 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
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
-- 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
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;
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.
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;
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;
-- 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
end if;
Initialization.Defer_Abort (Self_Id);
-
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Environment_Task);
Write_Lock (Self_Id);
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
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);
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;
with System.Task_Primitives.Operations;
with System.Restrictions;
-with System.Parameters;
with System.Tasking.Initialization;
pragma Elaborate_All (System.Tasking.Initialization);
package STPO renames System.Task_Primitives.Operations;
- use Parameters;
use Task_Primitives.Operations;
----------------
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
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;
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;
with System.Tasking.Rendezvous;
with System.Tasking.Utilities;
with System.Tasking.Debug;
-with System.Parameters;
with System.Restrictions;
with System.Tasking.Initialization;
package STPO renames System.Task_Primitives.Operations;
- use Parameters;
use Ada.Exceptions;
use Entries;
-- 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;
-- 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;
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
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
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;
-- 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);
-- 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
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;
-- 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
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);
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);
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
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
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
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
Exit_Outer : Boolean := False;
begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
Write_Lock (Self_ID);
Compute_Deadline
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
end if;
Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
pragma Unreferenced (Result);
Result := sched_yield;
end Timed_Delay;
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 --
-----------------------
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;
-------------------------
(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);
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);
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
-- 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 --
-------------------
-- 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 --
-------------------
-- 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 --
-------------------
-- 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 --
-------------------
projects / gcc.git / commitdiff