2010-10-26 Jerry DeLisle <jvdelisle@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / ada / s-taprop-mingw.adb

diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb
index 89e7dc1..768bc3f 100644 (file)
--- a/gcc/ada/s-taprop-mingw.adb
+++ b/gcc/ada/s-taprop-mingw.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---          Copyright (C) 1992-2009, 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- --
@@ -43,6 +43,7 @@ with Ada.Unchecked_Deallocation;
 with Interfaces.C;
 with Interfaces.C.Strings;
 
+with System.Multiprocessors;
 with System.Tasking.Debug;
 with System.OS_Primitives;
 with System.Task_Info;
@@ -312,18 +313,17 @@ package body System.Task_Primitives.Operations is
       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);
 
@@ -795,6 +795,9 @@ package body System.Task_Primitives.Operations is
       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;
@@ -808,17 +811,9 @@ package body System.Task_Primitives.Operations is
 
       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;
 
    --------------
@@ -896,6 +891,8 @@ package body System.Task_Primitives.Operations is
       Result         : DWORD;
       Entry_Point    : PTHREAD_START_ROUTINE;
 
+      use type System.Multiprocessors.CPU_Range;
+
    begin
       pTaskParameter := To_Address (T);
 
@@ -931,6 +928,15 @@ package body System.Task_Primitives.Operations is
 
       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);
@@ -940,22 +946,31 @@ package body System.Task_Primitives.Operations is
         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.
+
+         Result := SetThreadIdealProcessor
+           (hTask, ProcessorId (T.Common.Base_CPU) - 1);
+         pragma Assert (Result = 1);
 
-      if T.Common.Task_Info /= null then
+      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);
@@ -1059,6 +1074,10 @@ package body System.Task_Primitives.Operations is
       Discard : BOOL;
       pragma Unreferenced (Discard);
 
+      Result : DWORD;
+
+      use type System.Multiprocessors.CPU_Range;
+
    begin
       Environment_Task_Id := Environment_Task;
       OS_Primitives.Initialize;
@@ -1081,7 +1100,29 @@ package body System.Task_Primitives.Operations is
       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;
 
    ---------------------
@@ -1128,6 +1169,7 @@ package body System.Task_Primitives.Operations is
 
    procedure Finalize (S : in out Suspension_Object) is
       Result : BOOL;
+
    begin
       --  Destroy internal mutex
 
@@ -1206,6 +1248,7 @@ package body System.Task_Primitives.Operations is
    procedure Suspend_Until_True (S : in out Suspension_Object) is
       Result      : DWORD;
       Result_Bool : BOOL;
+
    begin
       SSL.Abort_Defer.all;