OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

s-osprim-mingw.adb (Timed_Delay): Use the right clock (standard one or the monotonic used by Ada.Real_Time) to... 

2007-04-06  Pascal Obry  <obry@adacore.com>

	* s-osprim-mingw.adb (Timed_Delay): Use the right clock (standard one
	or the monotonic used by Ada.Real_Time) to compute the sleep duration
	on Windows.

From-SVN: r123546
This commit is contained in:
Pascal Obry 2007-04-06 11:15:56 +02:00 committed by Arnaud Charlet
parent 2d7475246d
commit 2c851ddd1c
3 changed files with 40 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/ada/s-osinte-vxworks.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1997-2006 Free Software Foundation -- -- Copyright (C) 1997-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -31,7 +31,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This is the VxWorks version. -- This is the VxWorks version
-- This package encapsulates all direct interfaces to OS services -- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System. -- that are needed by children of System.
@ -45,7 +45,7 @@ package body System.OS_Interface is
use type Interfaces.C.int; use type Interfaces.C.int;
Low_Priority : constant := 255; Low_Priority : constant := 255;
-- VxWorks native (default) lowest scheduling priority. -- VxWorks native (default) lowest scheduling priority
------------ ------------
-- getpid -- -- getpid --
@ -123,12 +123,13 @@ package body System.OS_Interface is
function To_Timespec (D : Duration) return timespec is function To_Timespec (D : Duration) return timespec is
S : time_t; S : time_t;
F : Duration; F : Duration;
begin begin
S := time_t (Long_Long_Integer (D)); S := time_t (Long_Long_Integer (D));
F := D - Duration (S); F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F -- If F is negative due to a round-up, adjust for positive F value
-- value.
if F < 0.0 then if F < 0.0 then
S := S - 1; S := S - 1;
F := F + 1.0; F := F + 1.0;
@ -151,16 +152,15 @@ package body System.OS_Interface is
-- To_Clock_Ticks -- -- To_Clock_Ticks --
-------------------- --------------------
-- ??? - For now, we'll always get the system clock rate -- ??? - For now, we'll always get the system clock rate since it is
-- since it is allowed to be changed during run-time in -- allowed to be changed during run-time in VxWorks. A better method would
-- VxWorks. A better method would be to provide an operation -- be to provide an operation to set it that so we can always know its
-- to set it that so we can always know its value. -- value.
--
-- Another thing we should probably allow for is a resultant -- Another thing we should probably allow for is a resultant tick count
-- tick count greater than int'Last. This should probably -- greater than int'Last. This should probably be a procedure with two
-- be a procedure with two output parameters, one in the -- output parameters, one in the range 0 .. int'Last, and another
-- range 0 .. int'Last, and another representing the overflow -- representing the overflow count.
-- count.
function To_Clock_Ticks (D : Duration) return int is function To_Clock_Ticks (D : Duration) return int is
Ticks : Long_Long_Integer; Ticks : Long_Long_Integer;
@ -195,13 +195,4 @@ package body System.OS_Interface is
return int (Ticks); return int (Ticks);
end To_Clock_Ticks; end To_Clock_Ticks;
----------------
-- VX_FP_TASK --
----------------
function VX_FP_TASK return int is
begin
return 16#0008#;
end VX_FP_TASK;
end System.OS_Interface; end System.OS_Interface;

3
gcc/ada/s-osinte-vxworks.ads
View File

@ -275,9 +275,6 @@ package System.OS_Interface is
VX_FP_PRIVATE_ENV : constant := 16#0080#; VX_FP_PRIVATE_ENV : constant := 16#0080#;
VX_NO_STACK_FILL : constant := 16#0100#; VX_NO_STACK_FILL : constant := 16#0100#;
function VX_FP_TASK return int;
pragma Inline (VX_FP_TASK);
function taskSpawn function taskSpawn
(name : System.Address; -- Pointer to task name (name : System.Address; -- Pointer to task name
priority : int; priority : int;

53
gcc/ada/s-taprop-vxworks.adb
View File

@ -263,7 +263,8 @@ package body System.Task_Primitives.Operations is
-- Initialize_Lock -- -- Initialize_Lock --
--------------------- ---------------------
procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is procedure Initialize_Lock
(Prio : System.Any_Priority; L : not null access Lock) is
begin begin
L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
L.Prio_Ceiling := int (Prio); L.Prio_Ceiling := int (Prio);
@ -271,7 +272,9 @@ package body System.Task_Primitives.Operations is
pragma Assert (L.Mutex /= 0); pragma Assert (L.Mutex /= 0);
end Initialize_Lock; end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is procedure Initialize_Lock
(L : not null access RTS_Lock; Level : Lock_Level)
is
pragma Unreferenced (Level); pragma Unreferenced (Level);
begin begin
@ -285,14 +288,14 @@ package body System.Task_Primitives.Operations is
-- Finalize_Lock -- -- Finalize_Lock --
------------------- -------------------
procedure Finalize_Lock (L : access Lock) is procedure Finalize_Lock (L : not null access Lock) is
Result : int; Result : int;
begin begin
Result := semDelete (L.Mutex); Result := semDelete (L.Mutex);
pragma Assert (Result = 0); pragma Assert (Result = 0);
end Finalize_Lock; end Finalize_Lock;
procedure Finalize_Lock (L : access RTS_Lock) is procedure Finalize_Lock (L : not null access RTS_Lock) is
Result : int; Result : int;
begin begin
Result := semDelete (L.Mutex); Result := semDelete (L.Mutex);
@ -303,7 +306,9 @@ package body System.Task_Primitives.Operations is
-- Write_Lock -- -- Write_Lock --
---------------- ----------------
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is procedure Write_Lock
(L : not null access Lock; Ceiling_Violation : out Boolean)
is
Result : int; Result : int;
begin begin
if L.Protocol = Prio_Protect if L.Protocol = Prio_Protect
@ -320,7 +325,7 @@ package body System.Task_Primitives.Operations is
end Write_Lock; end Write_Lock;
procedure Write_Lock procedure Write_Lock
(L : access RTS_Lock; (L : not null access RTS_Lock;
Global_Lock : Boolean := False) Global_Lock : Boolean := False)
is is
Result : int; Result : int;
@ -344,7 +349,8 @@ package body System.Task_Primitives.Operations is
-- Read_Lock -- -- Read_Lock --
--------------- ---------------
procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is procedure Read_Lock
(L : not null access Lock; Ceiling_Violation : out Boolean) is
begin begin
Write_Lock (L, Ceiling_Violation); Write_Lock (L, Ceiling_Violation);
end Read_Lock; end Read_Lock;
@ -353,14 +359,16 @@ package body System.Task_Primitives.Operations is
-- Unlock -- -- Unlock --
------------ ------------
procedure Unlock (L : access Lock) is procedure Unlock (L : not null access Lock) is
Result : int; Result : int;
begin begin
Result := semGive (L.Mutex); Result := semGive (L.Mutex);
pragma Assert (Result = 0); pragma Assert (Result = 0);
end Unlock; end Unlock;
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is procedure Unlock
(L : not null access RTS_Lock; Global_Lock : Boolean := False)
is
Result : int; Result : int;
begin begin
if not Single_Lock or else Global_Lock then if not Single_Lock or else Global_Lock then
@ -903,12 +911,13 @@ package body System.Task_Primitives.Operations is
Name_Address : System.Address; Name_Address : System.Address;
-- Task name we are going to hand down to VxWorks -- Task name we are going to hand down to VxWorks
Task_Options : aliased int; function Get_Task_Options return int;
-- VxWorks options we are going to set for the created task, pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
-- a combination of VX_optname_TASK attributes. -- Function that returns the options to be set for the task that we
-- are creating. We fetch the options assigned to the current task,
function To_int is new Unchecked_Conversion (unsigned_int, int); -- so offering some user level control over the options for a task
function To_uint is new Unchecked_Conversion (int, unsigned_int); -- hierarchy, and force VX_FP_TASK because it is almost always
-- required.
begin begin
-- If there is no Ada task name handy, let VxWorks choose one. -- If there is no Ada task name handy, let VxWorks choose one.
@ -923,24 +932,12 @@ package body System.Task_Primitives.Operations is
Name_Address := Name'Address; Name_Address := Name'Address;
end if; end if;
-- For task options, we fetch the options assigned to the current
-- task, so offering some user level control over the options for a
-- task hierarchy, and force VX_FP_TASK because it is almost always
-- required.
if taskOptionsGet (taskIdSelf, Task_Options'Access) /= OK then
Task_Options := 0;
end if;
Task_Options :=
To_int (To_uint (Task_Options) or To_uint (VX_FP_TASK));
-- Now spawn the VxWorks task for real -- Now spawn the VxWorks task for real
T.Common.LL.Thread := taskSpawn T.Common.LL.Thread := taskSpawn
(Name_Address, (Name_Address,
To_VxWorks_Priority (int (Priority)), To_VxWorks_Priority (int (Priority)),
Task_Options, Get_Task_Options,
Adjusted_Stack_Size, Adjusted_Stack_Size,
Wrapper, Wrapper,
To_Address (T)); To_Address (T));