summaryrefslogtreecommitdiff
path: root/gcc/ada/7staprop.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada/7staprop.adb')
-rw-r--r--gcc/ada/7staprop.adb239
1 files changed, 132 insertions, 107 deletions
diff --git a/gcc/ada/7staprop.adb b/gcc/ada/7staprop.adb
index 82bffbc2b4c..b34292d9d4f 100644
--- a/gcc/ada/7staprop.adb
+++ b/gcc/ada/7staprop.adb
@@ -6,9 +6,9 @@
-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
+-- $Revision$
-- --
--- Copyright (C) 1991-2001, Florida State University --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -101,15 +101,17 @@ package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ ----------------
+ -- Local Data --
+ ----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
- All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
- -- See comments on locking rules in System.Tasking (spec).
+ 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
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -143,8 +145,7 @@ package body System.Task_Primitives.Operations is
-- Local Subprograms --
-----------------------
- procedure Abort_Handler
- (Sig : Signal);
+ procedure Abort_Handler (Sig : Signal);
function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
@@ -252,15 +253,13 @@ package body System.Task_Primitives.Operations is
-- Context.PC := Raise_Abort_Signal'Address;
-- return;
-- end if;
-
end Abort_Handler;
- -------------------
- -- Stack_Guard --
- -------------------
+ -----------------
+ -- Stack_Guard --
+ -----------------
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
-
Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
Guard_Page_Address : Address;
@@ -304,7 +303,7 @@ package body System.Task_Primitives.Operations is
-- Note: mutexes and cond_variables needed per-task basis are
-- initialized in Initialize_TCB and the Storage_Error is
- -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
-- used in RTS is initialized before any status change of RTS.
-- Therefore rasing Storage_Error in the following routines
-- should be able to be handled safely.
@@ -395,7 +394,6 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -403,7 +401,6 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -415,7 +412,6 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_lock (L);
@@ -425,20 +421,24 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Result = EINVAL);
end Write_Lock;
- procedure Write_Lock (L : access RTS_Lock) is
+ procedure Write_Lock
+ (L : access RTS_Lock; Global_Lock : Boolean := False)
+ is
Result : Interfaces.C.int;
-
begin
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
+ if not Single_Lock then
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
end Write_Lock;
---------------
@@ -456,40 +456,46 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
end Unlock;
- procedure Unlock (L : access RTS_Lock) is
+ procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
-
begin
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end if;
end Unlock;
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
+ if not Single_Lock then
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
end Unlock;
- -------------
- -- Sleep --
- -------------
+ -----------
+ -- Sleep --
+ -----------
- procedure Sleep (Self_ID : Task_ID;
- Reason : System.Tasking.Task_States) is
+ procedure Sleep
+ (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States)
+ is
Result : Interfaces.C.int;
-
begin
- pragma Assert (Self_ID = Self);
- Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access);
+ if Single_Lock then
+ Result := pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ else
+ Result := pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ end if;
-- EINTR is not considered a failure.
@@ -548,8 +554,16 @@ package body System.Task_Primitives.Operations is
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
or else Self_ID.Pending_Priority_Change;
- Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Request'Access);
+ if Single_Lock then
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
+ Request'Access);
+
+ else
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
+ Request'Access);
+ end if;
exit when Abs_Time <= Monotonic_Clock;
@@ -591,6 +605,11 @@ package body System.Task_Primitives.Operations is
-- check for pending abort and priority change below! :(
SSL.Abort_Defer.all;
+
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
Write_Lock (Self_ID);
if Mode = Relative then
@@ -626,8 +645,14 @@ package body System.Task_Primitives.Operations is
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Request'Access);
+ if Single_Lock then
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access, Request'Access);
+ else
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+ end if;
+
exit when Abs_Time <= Monotonic_Clock;
pragma Assert (Result = 0
@@ -639,6 +664,11 @@ package body System.Task_Primitives.Operations is
end if;
Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Result := sched_yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
@@ -673,7 +703,6 @@ package body System.Task_Primitives.Operations is
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -685,7 +714,6 @@ package body System.Task_Primitives.Operations is
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
begin
if Do_Yield then
Result := sched_yield;
@@ -697,8 +725,8 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
- (T : Task_ID;
- Prio : System.Any_Priority;
+ (T : Task_ID;
+ Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
Result : Interfaces.C.int;
@@ -744,17 +772,17 @@ package body System.Task_Primitives.Operations is
Specific.Set (Self_ID);
- Lock_All_Tasks_List;
+ Lock_RTS;
- for I in Known_Tasks'Range loop
- if Known_Tasks (I) = null then
- Known_Tasks (I) := Self_ID;
- Self_ID.Known_Tasks_Index := I;
+ for J in Known_Tasks'Range loop
+ if Known_Tasks (J) = null then
+ Known_Tasks (J) := Self_ID;
+ Self_ID.Known_Tasks_Index := J;
exit;
end if;
end loop;
- Unlock_All_Tasks_List;
+ Unlock_RTS;
end Enter_Task;
--------------
@@ -772,8 +800,8 @@ package body System.Task_Primitives.Operations is
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
- Cond_Attr : aliased pthread_condattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
begin
-- Give the task a unique serial number.
@@ -782,53 +810,50 @@ package body System.Task_Primitives.Operations is
Next_Serial_Number := Next_Serial_Number + 1;
pragma Assert (Next_Serial_Number /= 0);
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ if not Single_Lock then
+ 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_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
- 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);
- Result := pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access, Interfaces.C.int (System.Any_Priority'Last));
- pragma Assert (Result = 0);
+ 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_mutex_init (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
- if Result /= 0 then
- Succeeded := False;
- return;
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
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
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- Succeeded := False;
- return;
+ if Result = 0 then
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
- Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
if Result = 0 then
Succeeded := True;
else
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
Succeeded := False;
end if;
@@ -936,8 +961,10 @@ package body System.Task_Primitives.Operations is
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
begin
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
Result := pthread_cond_destroy (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -1001,23 +1028,23 @@ package body System.Task_Primitives.Operations is
return Environment_Task_ID;
end Environment_Task;
- -------------------------
- -- Lock_All_Tasks_List --
- -------------------------
+ --------------
+ -- Lock_RTS --
+ --------------
- procedure Lock_All_Tasks_List is
+ procedure Lock_RTS is
begin
- Write_Lock (All_Tasks_L'Access);
- end Lock_All_Tasks_List;
+ Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Lock_RTS;
- ---------------------------
- -- Unlock_All_Tasks_List --
- ---------------------------
+ ----------------
+ -- Unlock_RTS --
+ ----------------
- procedure Unlock_All_Tasks_List is
+ procedure Unlock_RTS is
begin
- Unlock (All_Tasks_L'Access);
- end Unlock_All_Tasks_List;
+ Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Unlock_RTS;
------------------
-- Suspend_Task --
@@ -1056,7 +1083,7 @@ package body System.Task_Primitives.Operations is
-- Initialize the lock used to synchronize chain of all ATCBs.
- Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
Specific.Initialize (Environment_Task);
@@ -1083,7 +1110,6 @@ package body System.Task_Primitives.Operations is
begin
declare
Result : Interfaces.C.int;
-
begin
-- Mask Environment task for all signals. The original mask of the
-- Environment task will be recovered by Interrupt_Server task
@@ -1104,5 +1130,4 @@ begin
end if;
end loop;
end;
-
end System.Task_Primitives.Operations;