--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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 --
-------------
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 --
-----------------------
-- 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);
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#;
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.
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;
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);
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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / platform / upstream / linaro-gcc.git / commitdiff