-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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. --
with Interfaces.C;
with Interfaces.C.Strings;
+with System.Multiprocessors;
with System.Tasking.Debug;
with System.OS_Primitives;
with System.Task_Info;
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);
---------------------
-- 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.
-- 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.
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for x86 systems
+ procedure Get_Stack_Bounds (Base : Address; Limit : Address);
+ pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
+ -- Get stack boundaries
begin
Specific.Set (Self_ID);
Init_Float;
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;
+ Get_Stack_Bounds
+ (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address,
+ Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
end Enter_Task;
--------------
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
+ use type System.Multiprocessors.CPU_Range;
+
begin
pTaskParameter := To_Address (T);
T.Common.LL.Thread := hTask;
+ -- Note: it would be useful to initialize Thread_Id right away to avoid
+ -- a race condition in gdb where Thread_ID may not have the right value
+ -- yet, but GetThreadId is a Vista specific API, not available under XP:
+ -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the
+ -- field to 0 to avoid having a random value. Thread_Id is initialized
+ -- in Enter_Task anyway.
+
+ T.Common.LL.Thread_Id := 0;
+
-- Step 3: set its priority (child has inherited priority from parent)
Set_Priority (T, Priority);
or else Get_Policy (Priority) = 'F'
then
-- Here we need Annex D semantics so we disable the NT priority
- -- boost. A priority boost is temporarily given by the system to a
- -- thread when it is taken out of a wait state.
+ -- 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 => Win32.TRUE);
end if;
- -- Step 4: Handle Task_Info
+ -- Step 4: Handle pragma CPU and Task_Info
+
+ if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then
+
+ -- The CPU numbering in pragma CPU starts at 1 while the subprogram
+ -- to set the affinity starts at 0, therefore we must substract 1.
- if T.Common.Task_Info /= null then
+ Result := SetThreadIdealProcessor
+ (hTask, ProcessorId (T.Common.Base_CPU) - 1);
+ pragma Assert (Result = 1);
+
+ elsif T.Common.Task_Info /= null then
if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then
Result := SetThreadIdealProcessor (hTask, T.Common.Task_Info.CPU);
pragma Assert (Result = 1);
end if;
end if;
- -- Step 5: Now, start it for good:
+ -- Step 5: Now, start it for good
Result := ResumeThread (hTask);
pragma Assert (Result = 1);
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);
Discard : BOOL;
pragma Unreferenced (Discard);
+ Result : DWORD;
+
+ use type System.Multiprocessors.CPU_Range;
+
begin
Environment_Task_Id := Environment_Task;
OS_Primitives.Initialize;
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);
+
+ -- pragma CPU for the environment task
+
+ if Environment_Task.Common.Base_CPU /=
+ System.Multiprocessors.Not_A_Specific_CPU
+ then
+ -- The CPU numbering in pragma CPU starts at 1 while the subprogram
+ -- to set the affinity starts at 0, therefore we must substract 1.
+
+ Result :=
+ SetThreadIdealProcessor
+ (Environment_Task.Common.LL.Thread,
+ ProcessorId (Environment_Task.Common.Base_CPU) - 1);
+ pragma Assert (Result = 1);
+ end if;
end Initialize;
---------------------
procedure Finalize (S : in out Suspension_Object) is
Result : BOOL;
+
begin
-- Destroy internal mutex
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : DWORD;
Result_Bool : BOOL;
+
begin
SSL.Abort_Defer.all;
OSDN Git Service
