-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
+-- $Revision$
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, 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- --
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
use System.Parameters;
use System.OS_Primitives;
- pragma Linker_Options ("-Xlinker --stack=0x800000,0x1000");
+ pragma Link_With ("-Xlinker --stack=0x800000,0x1000");
+ -- Change the stack size (8 MB) for tasking programs on Windows. This
+ -- permit to have more than 30 tasks running at the same time. Note that
+ -- we set the stack size for non tasking programs on System unit.
package SSL renames System.Soft_Links;
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
- 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
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
Fake_ATCB_List : Fake_ATCB_Ptr;
-- A linear linked list.
- -- The list is protected by All_Tasks_L;
+ -- The list is protected by Single_RTS_Lock;
-- Nodes are added to this list from the front.
-- Once a node is added to this list, it is never removed.
-- We dare not call anything that might require an ATCB, until
-- we have the new ATCB in place.
- Write_Lock (All_Tasks_L'Access);
+ Lock_RTS;
Q := null;
P := Fake_ATCB_List;
-- Must not unlock until Next_ATCB is again allocated.
- Unlock (All_Tasks_L'Access);
+ Unlock_RTS;
return Self_ID;
end New_Fake_ATCB;
-- 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...) used in
+ -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in
-- the RTS is initialized before any status change of RTS.
-- Therefore raising Storage_Error in the following routines
-- should be able to be handled safely.
Ceiling_Violation := False;
end Write_Lock;
- procedure Write_Lock (L : access RTS_Lock) is
+ procedure Write_Lock
+ (L : access RTS_Lock; Global_Lock : Boolean := False) is
begin
- EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ if not Single_Lock or else Global_Lock then
+ EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
begin
- EnterCriticalSection
- (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ if not Single_Lock then
+ EnterCriticalSection
+ (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ end if;
end Write_Lock;
---------------
LeaveCriticalSection (L.Mutex'Access);
end Unlock;
- procedure Unlock (L : access RTS_Lock) is
+ procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
begin
- LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ if not Single_Lock or else Global_Lock then
+ LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ end if;
end Unlock;
procedure Unlock (T : Task_ID) is
begin
- LeaveCriticalSection
- (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ if not Single_Lock then
+ LeaveCriticalSection
+ (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ end if;
end Unlock;
-----------
begin
pragma Assert (Self_ID = Self);
- Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ 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;
if Self_ID.Deferral_Level = 0
and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
begin
Timedout := True;
- Yielded := False;
+ Yielded := False;
if Mode = Relative then
Rel_Time := Time;
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
or else Self_ID.Pending_Priority_Change;
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
+ 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;
exit when Abs_Time <= Monotonic_Clock;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
- -- check for pending abort and priority change below! :(
+ -- 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
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
+ 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;
exit when Abs_Time <= Monotonic_Clock;
end if;
Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
Yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
- Lock_All_Tasks_List;
+ Lock_RTS;
for J in Known_Tasks'Range loop
if Known_Tasks (J) = null then
end if;
end loop;
- Unlock_All_Tasks_List;
+ Unlock_RTS;
end Enter_Task;
--------------
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
- ----------------------
- -- Initialize_TCB --
- ----------------------
+ --------------------
+ -- Initialize_TCB --
+ --------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
begin
Initialize_Cond (Self_ID.Common.LL.CV'Access);
- Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
+
+ if not Single_Lock then
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
+ end if;
+
Succeeded := True;
end Initialize_TCB;
is
hTask : HANDLE;
TaskId : aliased DWORD;
-
- -- ??? The fact that we can't use PVOID because the compiler
- -- gives a "PVOID is not visible" error is a GNAT bug.
- -- The strange thing is that the file compiles fine during a regular
- -- build.
-
pTaskParameter : System.OS_Interface.PVOID;
dwStackSize : DWORD;
Result : DWORD;
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
begin
- Finalize_Lock (T.Common.LL.L'Access);
+ if not Single_Lock then
+ Finalize_Lock (T.Common.LL.L'Access);
+ end if;
+
Finalize_Cond (T.Common.LL.CV'Access);
if T.Known_Tasks_Index /= -1 then
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;
----------------
-- Initialize --
-- 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);
Environment_Task.Common.LL.Thread := GetCurrentThread;
Enter_Task (Environment_Task);
OSDN Git Service
