From 89ce0207a2cbb8db3490005868cca90b94dc6e6e Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 08:44:02 +0000 Subject: [PATCH] 2007-08-14 Pascal Obry * 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 --- gcc/ada/a-exetim-mingw.adb | 160 +++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/a-exetim-mingw.ads | 98 +++++++++++++++++++++++++++ gcc/ada/s-osinte-mingw.ads | 34 ++++++++++ gcc/ada/s-taprop-mingw.adb | 38 ++++++++++- gcc/ada/s-tasinf-mingw.adb | 61 +++++++++++++++++ gcc/ada/s-tasinf-mingw.ads | 104 +++++++++++++++++++++++++++++ 6 files changed, 494 insertions(+), 1 deletion(-) create mode 100755 gcc/ada/a-exetim-mingw.adb create mode 100755 gcc/ada/a-exetim-mingw.ads create mode 100644 gcc/ada/s-tasinf-mingw.adb create mode 100644 gcc/ada/s-tasinf-mingw.ads diff --git a/gcc/ada/a-exetim-mingw.adb b/gcc/ada/a-exetim-mingw.adb new file mode 100755 index 0000000..bf2f271 --- /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 0000000..7ec45ba --- /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 af5a8fc..0fc713f 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 1c97935..603e243 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 0000000..530924e --- /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 0000000..baf2d8e --- /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; -- 2.7.4