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
Arnaud Charlet
parent
2d7475246d
commit
2c851ddd1c
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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 --
|
||||
-- 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
|
||||
-- that are needed by children of System.
|
||||
@ -45,7 +45,7 @@ package body System.OS_Interface is
|
||||
use type Interfaces.C.int;
|
||||
|
||||
Low_Priority : constant := 255;
|
||||
-- VxWorks native (default) lowest scheduling priority.
|
||||
-- VxWorks native (default) lowest scheduling priority
|
||||
|
||||
------------
|
||||
-- getpid --
|
||||
@ -123,12 +123,13 @@ package body System.OS_Interface is
|
||||
function To_Timespec (D : Duration) return timespec is
|
||||
S : time_t;
|
||||
F : Duration;
|
||||
|
||||
begin
|
||||
S := time_t (Long_Long_Integer (D));
|
||||
F := D - Duration (S);
|
||||
|
||||
-- If F has negative value due to a round-up, adjust for positive F
|
||||
-- value.
|
||||
-- If F is negative due to a round-up, adjust for positive F value
|
||||
|
||||
if F < 0.0 then
|
||||
S := S - 1;
|
||||
F := F + 1.0;
|
||||
@ -151,16 +152,15 @@ package body System.OS_Interface is
|
||||
-- To_Clock_Ticks --
|
||||
--------------------
|
||||
|
||||
-- ??? - For now, we'll always get the system clock rate
|
||||
-- since it is allowed to be changed during run-time in
|
||||
-- VxWorks. A better method would be to provide an operation
|
||||
-- to set it that so we can always know its value.
|
||||
--
|
||||
-- Another thing we should probably allow for is a resultant
|
||||
-- tick count greater than int'Last. This should probably
|
||||
-- be a procedure with two output parameters, one in the
|
||||
-- range 0 .. int'Last, and another representing the overflow
|
||||
-- count.
|
||||
-- ??? - For now, we'll always get the system clock rate since it is
|
||||
-- allowed to be changed during run-time in VxWorks. A better method would
|
||||
-- be to provide an operation to set it that so we can always know its
|
||||
-- value.
|
||||
|
||||
-- Another thing we should probably allow for is a resultant tick count
|
||||
-- greater than int'Last. This should probably be a procedure with two
|
||||
-- output parameters, one in the range 0 .. int'Last, and another
|
||||
-- representing the overflow count.
|
||||
|
||||
function To_Clock_Ticks (D : Duration) return int is
|
||||
Ticks : Long_Long_Integer;
|
||||
@ -195,13 +195,4 @@ package body System.OS_Interface is
|
||||
return int (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;
|
||||
|
||||
@ -275,9 +275,6 @@ package System.OS_Interface is
|
||||
VX_FP_PRIVATE_ENV : constant := 16#0080#;
|
||||
VX_NO_STACK_FILL : constant := 16#0100#;
|
||||
|
||||
function VX_FP_TASK return int;
|
||||
pragma Inline (VX_FP_TASK);
|
||||
|
||||
function taskSpawn
|
||||
(name : System.Address; -- Pointer to task name
|
||||
priority : int;
|
||||
|
||||
@ -263,7 +263,8 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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
|
||||
L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
|
||||
L.Prio_Ceiling := int (Prio);
|
||||
@ -271,7 +272,9 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (L.Mutex /= 0);
|
||||
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);
|
||||
|
||||
begin
|
||||
@ -285,14 +288,14 @@ package body System.Task_Primitives.Operations is
|
||||
-- Finalize_Lock --
|
||||
-------------------
|
||||
|
||||
procedure Finalize_Lock (L : access Lock) is
|
||||
procedure Finalize_Lock (L : not null access Lock) is
|
||||
Result : int;
|
||||
begin
|
||||
Result := semDelete (L.Mutex);
|
||||
pragma Assert (Result = 0);
|
||||
end Finalize_Lock;
|
||||
|
||||
procedure Finalize_Lock (L : access RTS_Lock) is
|
||||
procedure Finalize_Lock (L : not null access RTS_Lock) is
|
||||
Result : int;
|
||||
begin
|
||||
Result := semDelete (L.Mutex);
|
||||
@ -303,7 +306,9 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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;
|
||||
begin
|
||||
if L.Protocol = Prio_Protect
|
||||
@ -320,7 +325,7 @@ package body System.Task_Primitives.Operations is
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock;
|
||||
(L : not null access RTS_Lock;
|
||||
Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : int;
|
||||
@ -344,7 +349,8 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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
|
||||
Write_Lock (L, Ceiling_Violation);
|
||||
end Read_Lock;
|
||||
@ -353,14 +359,16 @@ package body System.Task_Primitives.Operations is
|
||||
-- Unlock --
|
||||
------------
|
||||
|
||||
procedure Unlock (L : access Lock) is
|
||||
procedure Unlock (L : not null access Lock) is
|
||||
Result : int;
|
||||
begin
|
||||
Result := semGive (L.Mutex);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
begin
|
||||
if not Single_Lock or else Global_Lock then
|
||||
@ -903,12 +911,13 @@ package body System.Task_Primitives.Operations is
|
||||
Name_Address : System.Address;
|
||||
-- Task name we are going to hand down to VxWorks
|
||||
|
||||
Task_Options : aliased int;
|
||||
-- VxWorks options we are going to set for the created task,
|
||||
-- a combination of VX_optname_TASK attributes.
|
||||
|
||||
function To_int is new Unchecked_Conversion (unsigned_int, int);
|
||||
function To_uint is new Unchecked_Conversion (int, unsigned_int);
|
||||
function Get_Task_Options return int;
|
||||
pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
|
||||
-- Function that returns the options to be set for the task that we
|
||||
-- are creating. 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.
|
||||
|
||||
begin
|
||||
-- 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;
|
||||
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
|
||||
|
||||
T.Common.LL.Thread := taskSpawn
|
||||
(Name_Address,
|
||||
To_VxWorks_Priority (int (Priority)),
|
||||
Task_Options,
|
||||
Get_Task_Options,
|
||||
Adjusted_Stack_Size,
|
||||
Wrapper,
|
||||
To_Address (T));
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user