Skip to content

R
riscv-gcc-1
Commit a2264f2d by Pascal Obry Committed by Arnaud Charlet
Options

s-osinte-mingw.ads: Add support for Ada.Execution_Time on Windows. 

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.

From-SVN: r127434
parent 43316a01
Showing with 494 additions and 1 deletions
gcc/ada/a-exetim-mingw.adb 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-exetim-mingw.ads 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
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#;
......
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;
gcc/ada/s-tasinf-mingw.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-tasinf-mingw.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment