-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- This is a NT (native) version of this package
--- This package contains all the GNULL primitives that interface directly
--- with the underlying OS.
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-with System.Tasking.Debug;
--- used for Known_Tasks
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
-with System.OS_Primitives;
--- used for Delay_Modes
+with Ada.Unchecked_Deallocation;
with Interfaces.C;
--- used for int
--- size_t
-
with Interfaces.C.Strings;
--- used for Null_Ptr
+with System.Tasking.Debug;
+with System.OS_Primitives;
with System.Task_Info;
--- used for Unspecified_Task_Info
-
with System.Interrupt_Management;
--- used for Initialize
+with System.Win32.Ext;
with System.Soft_Links;
--- used for Abort_Defer/Undefer
-
-- We use System.Soft_Links instead of System.Tasking.Initialization because
-- the later is a higher level package that we shouldn't depend on. For
-- example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Ada.Unchecked_Deallocation;
-
package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
use System.Parameters;
use System.OS_Primitives;
use System.Task_Info;
+ use System.Win32;
+ use System.Win32.Ext;
pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
-- Change the default stack size (2 MB) for tasking programs on Windows.
-- Also note that under Windows XP, we use a Windows XP extension to
-- specify the stack size on a per task basis, as done under other OSes.
+ ---------------------
+ -- Local Functions --
+ ---------------------
+
+ procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure InitializeCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import
+ (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
+
+ procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure EnterCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
+
+ procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
+
+ procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure DeleteCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
+
----------------
-- Local Data --
----------------
Succeeded : BOOL;
begin
Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
- pragma Assert (Succeeded = True);
+ pragma Assert (Succeeded = Win32.TRUE);
end Set;
end Specific;
procedure Initialize_Cond (Cond : not null access Condition_Variable) is
hEvent : HANDLE;
begin
- hEvent := CreateEvent (null, True, False, Null_Ptr);
+ hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
pragma Assert (hEvent /= 0);
Cond.all := Condition_Variable (hEvent);
end Initialize_Cond;
Result : BOOL;
begin
Result := CloseHandle (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Finalize_Cond;
-----------------
Result : BOOL;
begin
Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Cond_Signal;
---------------
-- Must reset Cond BEFORE L is unlocked
Result_Bool := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result_Bool = True);
+ pragma Assert (Result_Bool = Win32.TRUE);
Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled,
-- Must reset Cond BEFORE L is unlocked
Result := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled,
- -- WaitForSingleObject will simply not block
+ -- WaitForSingleObject will simply not block.
if Rel_Time <= 0.0 then
Timed_Out := True;
Wait_Result := 0;
else
- if Rel_Time >= Duration (Time_Out_Max) / 1000 then
- Time_Out := Time_Out_Max;
- else
- Time_Out := DWORD (Rel_Time * 1000);
- end if;
+ Time_Out :=
+ (if Rel_Time >= Duration (Time_Out_Max) / 1000
+ then Time_Out_Max
+ else DWORD (Rel_Time * 1000));
Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
if Timed_Out then
Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end if;
Status := Integer (Wait_Result);
---------------------
-- Note: mutexes and cond_variables needed per-task basis are initialized
- -- in Intialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- in Initialize_TCB and the Storage_Error is handled. 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.
is
pragma Unreferenced (Level);
begin
- InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ InitializeCriticalSection (L);
end Initialize_Lock;
-------------------
procedure Finalize_Lock (L : not null access RTS_Lock) is
begin
- DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ DeleteCriticalSection (L);
end Finalize_Lock;
----------------
is
begin
if not Single_Lock or else Global_Lock then
- EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ EnterCriticalSection (L);
end if;
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
begin
if not Single_Lock then
- EnterCriticalSection
- (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ EnterCriticalSection (T.Common.LL.L'Access);
end if;
end Write_Lock;
(L : not null access RTS_Lock; Global_Lock : Boolean := False) is
begin
if not Single_Lock or else Global_Lock then
- LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ LeaveCriticalSection (L);
end if;
end Unlock;
procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
- LeaveCriticalSection
- (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ LeaveCriticalSection (T.Common.LL.L'Access);
end if;
end Unlock;
Check_Time : Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
- Result : Integer;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
Local_Timedout : Boolean;
Check_Time : Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
- Timedout : Boolean;
- Result : Integer;
- pragma Warnings (Off, Integer);
+ Timedout : Boolean;
+ Result : Integer;
+ pragma Unreferenced (Timedout, Result);
begin
if Single_Lock then
begin
Res := SetThreadPriority
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
- pragma Assert (Res = True);
+ pragma Assert (Res = Win32.TRUE);
if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then
-- This is because the GetCurrentThread NT call does not return the real
-- thread handler but only a "pseudo" one. It is not possible to release
- -- the thread handle and free the system ressources from this "pseudo"
+ -- the thread handle and free the system resources from this "pseudo"
-- handle. So we really want to keep the real thread handle set in
-- System.Task_Primitives.Operations.Create_Task during thread creation.
end if;
Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
-
- Lock_RTS;
-
- 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_RTS;
end Enter_Task;
--------------
hTask : HANDLE;
TaskId : aliased DWORD;
- pTaskParameter : System.OS_Interface.PVOID;
+ pTaskParameter : Win32.PVOID;
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
-- Step 1: Create the thread in blocked mode
if hTask = 0 then
- raise Storage_Error;
+ Succeeded := False;
+ return;
end if;
-- Step 2: set its TCB
-- boost. A priority boost is temporarily given by the system to a
-- thread when it is taken out of a wait state.
- SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
+ SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE);
end if;
-- Step 4: Handle Task_Info
if Self_ID.Common.LL.Thread /= 0 then
-- This task has been activated. Wait for the thread to terminate
- -- then close it. this is needed to release system ressources.
+ -- then close it. This is needed to release system resources.
Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
pragma Assert (Result /= WAIT_FAILED);
Succeeded := CloseHandle (T.Common.LL.Thread);
- pragma Assert (Succeeded = True);
+ pragma Assert (Succeeded = Win32.TRUE);
end if;
Free (Self_ID);
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
Environment_Task.Common.LL.Thread := GetCurrentThread;
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
Enter_Task (Environment_Task);
end Initialize;
-- Initialize internal condition variable
- S.CV := CreateEvent (null, True, False, Null_Ptr);
+ S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
pragma Assert (S.CV /= 0);
end Initialize;
-- Destroy internal condition variable
Result := CloseHandle (S.CV);
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Finalize;
-------------------
S.State := False;
Result := SetEvent (S.CV);
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
else
S.State := True;
end if;
-- Must reset CV BEFORE L is unlocked
Result_Bool := ResetEvent (S.CV);
- pragma Assert (Result_Bool = True);
+ pragma Assert (Result_Bool = Win32.TRUE);
LeaveCriticalSection (S.L'Access);
OSDN Git Service
