2007-08-14 Pascal Obry <obry@adacore.com>

	* s-osinte-mingw.ads: Add support for Ada.Execution_Time on Windows.
	(SYSTEM_INFO): New record.
	(SetThreadIdealProcessor): New imported routine needed for supporting
	task_info pragma on Windows.

	* s-taprop-mingw.adb (Enter_Task): Check if CPU number given in task
	info can be applied to the current host.
	(Create_Task): Set the ideal processor if information is present.

	* s-tasinf-mingw.adb, s-tasinf-mingw.ads,
	a-exetim-mingw.adb, a-exetim-mingw.ads: New files.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127434 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 494 insertions, 1 deletions

diff --git a/gcc/ada/a-exetim-mingw.adb b/gcc/ada/a-exetim-mingw.adb
new file mode 100755
index 00000000000..bf2f271c045
--- /dev/null
+++ b/gcc/ada/a-exetim-mingw.adb
@@ -0,0 +1,160 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                   A D A . E X E C U T I O N _ T I M E                    --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--            Copyright (C) 2007, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT 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.  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 GNAT;  see file COPYING.  If not, write --
+-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
+-- Boston, MA 02110-1301, USA.                                              --
+--                                                                          --
+-- 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.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the Windows native version of this package
+
+with Ada.Task_Identification;           use Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with System.OS_Interface;               use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+with System.Tasking;                    use System.Tasking;
+
+package body Ada.Execution_Time is
+
+   ---------
+   -- "+" --
+   ---------
+
+   function "+"
+     (Left  : CPU_Time;
+      Right : Ada.Real_Time.Time_Span) return CPU_Time
+   is
+      use type Ada.Real_Time.Time;
+   begin
+      return CPU_Time (Ada.Real_Time.Time (Left) + Right);
+   end "+";
+
+   function "+"
+     (Left  : Ada.Real_Time.Time_Span;
+      Right : CPU_Time) return CPU_Time
+   is
+      use type Ada.Real_Time.Time;
+   begin
+      return CPU_Time (Left + Ada.Real_Time.Time (Right));
+   end "+";
+
+   ---------
+   -- "-" --
+   ---------
+
+   function "-"
+     (Left  : CPU_Time;
+      Right : Ada.Real_Time.Time_Span) return CPU_Time
+   is
+      use type Ada.Real_Time.Time;
+   begin
+      return CPU_Time (Ada.Real_Time.Time (Left) - Right);
+   end "-";
+
+   function "-"
+     (Left  : CPU_Time;
+      Right : CPU_Time) return Ada.Real_Time.Time_Span
+   is
+      use type Ada.Real_Time.Time;
+   begin
+      return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
+   end "-";
+
+   -----------
+   -- Clock --
+   -----------
+
+   function Clock
+     (T : Ada.Task_Identification.Task_Id :=
+            Ada.Task_Identification.Current_Task) return CPU_Time
+   is
+      Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
+
+      function To_Time is new Ada.Unchecked_Conversion
+        (Duration, Ada.Real_Time.Time);
+
+      function To_Task_Id is new Ada.Unchecked_Conversion
+        (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
+
+      C_Time : aliased Long_Long_Integer;
+      E_Time : aliased Long_Long_Integer;
+      K_Time : aliased Long_Long_Integer;
+      U_Time : aliased Long_Long_Integer;
+      Res    : BOOL;
+
+   begin
+      if T = Ada.Task_Identification.Null_Task_Id then
+         raise Program_Error;
+      end if;
+
+      Res :=
+        GetThreadTimes
+          (HANDLE (Get_Thread_Id (To_Task_Id (T))),
+           C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access);
+
+      if Res = False then
+         raise Program_Error;
+      end if;
+
+      return
+        CPU_Time
+          (To_Time
+             (Duration
+                ((Long_Long_Float (K_Time) / Hundreds_Nano_In_Sec)
+                 + (Long_Long_Float (U_Time) / Hundreds_Nano_In_Sec))));
+   end Clock;
+
+   -----------
+   -- Split --
+   -----------
+
+   procedure Split
+     (T  : CPU_Time;
+      SC : out Ada.Real_Time.Seconds_Count;
+      TS : out Ada.Real_Time.Time_Span)
+   is
+      use type Ada.Real_Time.Time;
+   begin
+      Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
+   end Split;
+
+   -------------
+   -- Time_Of --
+   -------------
+
+   function Time_Of
+     (SC : Ada.Real_Time.Seconds_Count;
+      TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+      return CPU_Time
+   is
+   begin
+      return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
+   end Time_Of;
+
+end Ada.Execution_Time;
diff --git a/gcc/ada/a-exetim-mingw.ads b/gcc/ada/a-exetim-mingw.ads
new file mode 100755
index 00000000000..7ec45ba353d
--- /dev/null
+++ b/gcc/ada/a-exetim-mingw.ads
@@ -0,0 +1,98 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                   A D A . E X E C U T I O N _ T I M E                    --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
+-- GNAT 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.  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 GNAT;  see file COPYING.  If not, write --
+-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
+-- Boston, MA 02110-1301, USA.                                              --
+--                                                                          --
+-- 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.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+------------------------------------------------------------------------------
+
+--  This is the Windows native version of this package
+
+with Ada.Task_Identification;
+with Ada.Real_Time;
+
+package Ada.Execution_Time is
+
+   type CPU_Time is private;
+
+   CPU_Time_First : constant CPU_Time;
+   CPU_Time_Last  : constant CPU_Time;
+   CPU_Time_Unit  : constant := 0.000001;
+   CPU_Tick       : constant Ada.Real_Time.Time_Span;
+
+   function Clock
+     (T : Ada.Task_Identification.Task_Id :=
+            Ada.Task_Identification.Current_Task) return CPU_Time;
+
+   function "+"
+     (Left  : CPU_Time;
+      Right : Ada.Real_Time.Time_Span) return CPU_Time;
+
+   function "+"
+     (Left  : Ada.Real_Time.Time_Span;
+      Right : CPU_Time) return CPU_Time;
+
+   function "-"
+     (Left  : CPU_Time;
+      Right : Ada.Real_Time.Time_Span) return CPU_Time;
+
+   function "-"
+     (Left  : CPU_Time;
+      Right : CPU_Time) return Ada.Real_Time.Time_Span;
+
+   function "<"  (Left, Right : CPU_Time) return Boolean;
+   function "<=" (Left, Right : CPU_Time) return Boolean;
+   function ">"  (Left, Right : CPU_Time) return Boolean;
+   function ">=" (Left, Right : CPU_Time) return Boolean;
+
+   procedure Split
+     (T  : CPU_Time;
+      SC : out Ada.Real_Time.Seconds_Count;
+      TS : out Ada.Real_Time.Time_Span);
+
+   function Time_Of
+      (SC : Ada.Real_Time.Seconds_Count;
+       TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+       return CPU_Time;
+
+private
+
+   type CPU_Time is new Ada.Real_Time.Time;
+
+   CPU_Time_First : constant CPU_Time  := CPU_Time (Ada.Real_Time.Time_First);
+   CPU_Time_Last  : constant CPU_Time  := CPU_Time (Ada.Real_Time.Time_Last);
+
+   CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
+
+   pragma Import (Intrinsic, "<");
+   pragma Import (Intrinsic, "<=");
+   pragma Import (Intrinsic, ">");
+   pragma Import (Intrinsic, ">=");
+
+end Ada.Execution_Time;
diff --git a/gcc/ada/s-osinte-mingw.ads b/gcc/ada/s-osinte-mingw.ads
index af5a8fc20c9..0fc713f774f 100644
--- a/gcc/ada/s-osinte-mingw.ads
+++ b/gcc/ada/s-osinte-mingw.ads
@@ -95,6 +95,25 @@ package System.OS_Interface is
    NO_ERROR : constant := 0;
    FUNC_ERR : constant := -1;
 
+   ------------------------
+   -- System Information --
+   ------------------------
+
+   type SYSTEM_INFO is record
+      dwOemId                     : DWORD;
+      dwPageSize                  : DWORD;
+      lpMinimumApplicationAddress : PVOID;
+      lpMaximumApplicationAddress : PVOID;
+      dwActiveProcessorMask       : DWORD;
+      dwNumberOfProcessors        : DWORD;
+      dwProcessorType             : DWORD;
+      dwAllocationGranularity     : DWORD;
+      dwReserved                  : DWORD;
+   end record;
+
+   procedure GetSystemInfo (SI : access SYSTEM_INFO);
+   pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
+
    -------------
    -- Signals --
    -------------
@@ -194,6 +213,14 @@ package System.OS_Interface is
    procedure SwitchToThread;
    pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
 
+   function GetThreadTimes
+     (hThread        : HANDLE;
+      lpCreationTime : access Long_Long_Integer;
+      lpExitTime     : access Long_Long_Integer;
+      lpKernelTime   : access Long_Long_Integer;
+      lpUserTime     : access Long_Long_Integer) return BOOL;
+   pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
+
    -----------------------
    -- Critical sections --
    -----------------------
@@ -221,6 +248,8 @@ package System.OS_Interface is
    -- Thread Creation, Activation, Suspension And Termination --
    -------------------------------------------------------------
 
+   subtype ProcessorId is DWORD;
+
    type PTHREAD_START_ROUTINE is access function
      (pThreadParameter : PVOID) return DWORD;
    pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
@@ -329,6 +358,11 @@ package System.OS_Interface is
       fAlertable     : BOOL) return DWORD;
    pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
 
+   function SetThreadIdealProcessor
+     (hThread          : HANDLE;
+      dwIdealProcessor : ProcessorId) return DWORD;
+   pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor");
+
    Wait_Infinite : constant := DWORD'Last;
    WAIT_TIMEOUT  : constant := 16#0000_0102#;
    WAIT_FAILED   : constant := 16#FFFF_FFFF#;
diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb
index 1c979355b20..603e2430378 100644
--- a/gcc/ada/s-taprop-mingw.adb
+++ b/gcc/ada/s-taprop-mingw.adb
@@ -80,6 +80,7 @@ package body System.Task_Primitives.Operations is
    use System.OS_Interface;
    use System.Parameters;
    use System.OS_Primitives;
+   use System.Task_Info;
 
    pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
    --  Change the default stack size (2 MB) for tasking programs on Windows.
@@ -786,6 +787,13 @@ package body System.Task_Primitives.Operations is
       Specific.Set (Self_ID);
       Init_Float;
 
+      if Self_ID.Common.Task_Info /= null
+        and then
+          Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors)
+      then
+         raise Invalid_CPU_Number;
+      end if;
+
       Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
 
       Lock_RTS;
@@ -925,7 +933,16 @@ package body System.Task_Primitives.Operations is
          SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
       end if;
 
-      --  Step 4: Now, start it for good:
+      --  Step 4: Handle Task_Info
+
+      if 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:
 
       Result := ResumeThread (hTask);
       pragma Assert (Result = 1);
@@ -1275,4 +1292,23 @@ package body System.Task_Primitives.Operations is
       end if;
    end Resume_Task;
 
+   --------------------
+   -- Stop_All_Tasks --
+   --------------------
+
+   procedure Stop_All_Tasks is
+   begin
+      null;
+   end Stop_All_Tasks;
+
+   -------------------
+   -- Continue_Task --
+   -------------------
+
+   function Continue_Task (T : ST.Task_Id) return Boolean is
+      pragma Unreferenced (T);
+   begin
+      return False;
+   end Continue_Task;
+
 end System.Task_Primitives.Operations;
diff --git a/gcc/ada/s-tasinf-mingw.adb b/gcc/ada/s-tasinf-mingw.adb
new file mode 100644
index 00000000000..530924efaca
--- /dev/null
+++ b/gcc/ada/s-tasinf-mingw.adb
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                     S Y S T E M . T A S K _ I N F O                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2007, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT 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.  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 GNAT;  see file COPYING.  If not, write --
+-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
+-- Boston, MA 02110-1301, USA.                                              --
+--                                                                          --
+-- 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.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the Windows (native) version of this module
+
+package body System.Task_Info is
+
+   N_CPU : Natural := 0;
+   pragma Atomic (N_CPU);
+   --  Cache CPU number. Use pragma Atomic to avoid a race condition when
+   --  setting N_CPU in Number_Of_Processors below.
+
+   --------------------------
+   -- Number_Of_Processors --
+   --------------------------
+
+   function Number_Of_Processors return Positive is
+   begin
+      if N_CPU = 0 then
+         declare
+            SI : aliased System.OS_Interface.SYSTEM_INFO;
+         begin
+            System.OS_Interface.GetSystemInfo (SI'Access);
+            N_CPU := Positive (SI.dwNumberOfProcessors);
+         end;
+      end if;
+
+      return N_CPU;
+   end Number_Of_Processors;
+
+end System.Task_Info;
diff --git a/gcc/ada/s-tasinf-mingw.ads b/gcc/ada/s-tasinf-mingw.ads
new file mode 100644
index 00000000000..baf2d8eaedc
--- /dev/null
+++ b/gcc/ada/s-tasinf-mingw.ads
@@ -0,0 +1,104 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                     S Y S T E M . T A S K _ I N F O                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2007, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT 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.  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 GNAT;  see file COPYING.  If not, write --
+-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
+-- Boston, MA 02110-1301, USA.                                              --
+--                                                                          --
+-- 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.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains the definitions and routines associated with the
+--  implementation and use of the Task_Info pragma. It is specialized
+--  appropriately for targets that make use of this pragma.
+
+--  Note: the compiler generates direct calls to this interface, via Rtsfind.
+--  Any changes to this interface may require corresponding compiler changes.
+
+--  This unit may be used directly from an application program by providing
+--  an appropriate WITH, and the interface can be expected to remain stable.
+
+--  This is the Windows (native) version of this module.
+
+with System.OS_Interface;
+
+package System.Task_Info is
+   pragma Preelaborate;
+   pragma Elaborate_Body;
+   --  To ensure that a body is allowed
+
+   use type System.OS_Interface.ProcessorId;
+
+   --  Windows provides a way to define the ideal processor to use for a given
+   --  thread. The ideal processor is not necessarily the one that will be used
+   --  by the OS but the OS will always try to schedule this thread to the
+   --  specified processor if it is available.
+
+   --  The Task_Info pragma:
+
+   --    pragma Task_Info (EXPRESSION);
+
+   --  allows the specification on a task by task basis of a value of type
+   --  System.Task_Info.Task_Info_Type to be passed to a task when it is
+   --  created. The specification of this type, and the effect on the task
+   --  that is created is target dependent.
+
+   --  The Task_Info pragma appears within a task definition (compare the
+   --  definition and implementation of pragma Priority). If no such pragma
+   --  appears, then the value Unspecified_Task_Info is passed. If a pragma
+   --  is present, then it supplies an alternative value. If the argument of
+   --  the pragma is a discriminant reference, then the value can be set on
+   --  a task by task basis by supplying the appropriate discriminant value.
+
+   --  Note that this means that the type used for Task_Info_Type must be
+   --  suitable for use as a discriminant (i.e. a scalar or access type).
+
+   -----------------------
+   -- Thread Attributes --
+   -----------------------
+
+   subtype CPU_Number is System.OS_Interface.ProcessorId;
+
+   Any_CPU : constant CPU_Number := -1;
+
+   Invalid_CPU_Number : exception;
+   --  Raised when an invalid CPU number has been specified
+   --  i.e. CPU > Number_Of_Processors.
+
+   type Thread_Attributes is record
+      CPU : CPU_Number := Any_CPU;
+   end record;
+
+   Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
+
+   type Task_Info_Type is access all Thread_Attributes;
+
+   Unspecified_Task_Info : constant Task_Info_Type := null;
+
+   function Number_Of_Processors return Positive;
+   --  Returns the number of processors on the running host
+
+end System.Task_Info;