Jose Ruiz <ruiz@adacore.com>
* s-taprop-vxworks.adb:
Move with clauses outside Warnings Off now that dependent units are
Preelaborate.
(Initialize): Call Interrupt_Managemeent.Initialize to ensure proper
initialization of this unit.
(Specific): Add new procedures Initialize and Delete so that this
package can be used for VxWorks 5.x and 6.x
(ATCB_Key, ATCB_Key_Address): Moved to Specific package body to hide
differences between VxWorks 5.x and 6.x
Minor reformatting.
(Timed_Delay): Remove calls to Defer/Undefer_Abort, now performed by
caller.
Use only Preelaborate-compatible constructs.
* s-tpopsp-vxworks.adb (ATBC_Key, ATCB_Key_Addr): Moved from
Primitives.Operations.
(Delete, Initialize): New procedures.
* s-osinte-vxworks.adb: Body used to handle differences between
VxWorks 5.x and 6.x
(kill, Set_Time_Slice, VX_FP_TASK): New functions.
* s-osinte-vxworks.ads: Minor reformatting.
Add VxWworks 6.x specific functions (only called from VxWorks 6 files).
(VX_FP_TASK): Now a function, to handle differences between VxWorks 5
and 6.
(Set_Time_Slice): New function, replacing kerneltimeSlice to share code
between Vxworks 5 and 6.
(taskLock, taskUnlock): Removeed, no longer used.
* adaint.c: The wait.h header is not located in the sys directory on
VxWorks when using RTPs.
(__gnat_set_env_value): Use setenv instead of putenv on VxWorks when
using RTPs.
(__gnat_dup): dup is available on Vxworks when using RTPs.
(__gnat_dup2): dup2 is available on Vxworks when using RTPs.
* cal.c: Use the header time.h for Vxworks 6.0 when using RTPs.
* expect.c: The wait.h header is not located in the sys directory on
VxWorks when using RTPs.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103852
138bc75d-0d04-0410-961f-
82ee72b054a4
#if OLD_MINGW
#include <sys/wait.h>
#endif
+#elif defined (__vxworks) && defined (__RTP__)
+#include <wait.h>
#else
#include <sys/wait.h>
#endif
LIB$SIGNAL (status);
}
+#elif defined (__vxworks) && defined (__RTP__)
+ setenv (name, value, 1);
+
#else
int size = strlen (name) + strlen (value) + 2;
char *expression;
int
__gnat_dup (int oldfd)
{
-#if defined (__vxworks)
- /* Not supported on VxWorks. */
- return -1;
+#if defined (__vxworks) && !defined (__RTP__)
+ /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
+ RTPs. */
+ return -1;
#else
- return dup (oldfd);
+ return dup (oldfd);
#endif
}
int
__gnat_dup2 (int oldfd, int newfd)
{
-#if defined (__vxworks)
- /* Not supported on VxWorks. */
+#if defined (__vxworks) && !defined (__RTP__)
+ /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
+ RTPs. */
return -1;
#else
return dup2 (oldfd, newfd);
#else
#if defined (__vxworks)
+#ifdef __RTP__
+#include <time.h>
+#else
#include <sys/times.h>
+#endif
#else
#include <sys/time.h>
#endif
#if OLD_MINGW
#include <sys/wait.h>
#endif
+#elif defined (__vxworks) && defined (__RTP__)
+#include <wait.h>
#else
#include <sys/wait.h>
#endif
Low_Priority : constant := 255;
-- VxWorks native (default) lowest scheduling priority.
+ ----------
+ -- kill --
+ ----------
+
+ function kill (pid : t_id; sig : Signal) return int is
+ function c_kill (pid : t_id; sig : Signal) return int;
+ pragma Import (C, c_kill, "kill");
+ begin
+ return c_kill (pid, sig);
+ end kill;
+
+ --------------------
+ -- Set_Time_Slice --
+ --------------------
+
+ function Set_Time_Slice (ticks : int) return int is
+ function kernelTimeSlice (ticks : int) return int;
+ pragma Import (C, kernelTimeSlice, "kernelTimeSlice");
+ begin
+ return kernelTimeSlice (ticks);
+ end Set_Time_Slice;
+
-------------
-- sigwait --
-------------
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;
package System.OS_Interface is
pragma Preelaborate;
- subtype int is Interfaces.C.int;
- subtype short is Short_Integer;
- type long is new Long_Integer;
- type unsigned_long is mod 2 ** long'Size;
- type size_t is mod 2 ** Standard'Address_Size;
+ subtype int is Interfaces.C.int;
+ subtype short is Short_Integer;
+ type long is new Long_Integer;
+ type unsigned_long is mod 2 ** long'Size;
+ type size_t is mod 2 ** Standard'Address_Size;
-----------
-- Errno --
subtype Thread_Id is t_id;
function kill (pid : t_id; sig : Signal) return int;
- pragma Import (C, kill, "kill");
+ pragma Inline (kill);
- -- VxWorks doesn't have getpid; taskIdSelf is the equivalent
- -- routine.
function getpid return t_id;
pragma Import (C, getpid, "taskIdSelf");
+ -- VxWorks doesn't have getpid; taskIdSelf is the equivalent routine.
----------
-- Time --
pragma Inline (To_Timespec);
function To_Clock_Ticks (D : Duration) return int;
- -- Convert a duration value (in seconds) into clock ticks.
+ -- Convert a duration value (in seconds) into clock ticks
function clock_gettime
(clock_id : clockid_t; tp : access timespec) return int;
function taskIsSuspended (tid : t_id) return int;
pragma Import (C, taskIsSuspended, "taskIsSuspended");
+ function taskDelay (ticks : int) return int;
+ procedure taskDelay (ticks : int);
+ pragma Import (C, taskDelay, "taskDelay");
+
+ function sysClkRateGet return int;
+ pragma Import (C, sysClkRateGet, "sysClkRateGet");
+
+ -- VxWorks 5.x specific functions
+
function taskVarAdd
(tid : t_id; pVar : access System.Address) return int;
pragma Import (C, taskVarAdd, "taskVarAdd");
pVar : access System.Address) return int;
pragma Import (C, taskVarGet, "taskVarGet");
- function taskDelay (ticks : int) return int;
- procedure taskDelay (ticks : int);
- pragma Import (C, taskDelay, "taskDelay");
+ -- VxWorks 6.x specific functions
- function sysClkRateGet return int;
- pragma Import (C, sysClkRateGet, "sysClkRateGet");
+ function tlsKeyCreate return int;
+ pragma Import (C, tlsKeyCreate, "tlsKeyCreate");
+
+ function tlsValueGet (key : int) return System.Address;
+ pragma Import (C, tlsValueGet, "tlsValueGet");
+
+ function tlsValueSet (key : int; value : System.Address) return STATUS;
+ pragma Import (C, tlsValueSet, "tlsValueSet");
-- Option flags for taskSpawn
VX_UNBREAKABLE : constant := 16#0002#;
- VX_FP_TASK : constant := 16#0008#;
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;
procedure taskDelete (tid : t_id);
pragma Import (C, taskDelete, "taskDelete");
- function kernelTimeSlice (ticks : int) return int;
- pragma Import (C, kernelTimeSlice, "kernelTimeSlice");
+ function Set_Time_Slice (ticks : int) return int;
+ pragma Inline (Set_Time_Slice);
+ -- Calls kernelTimeSlice under VxWorks 5.x
+ -- Do nothing under VxWorks 6.x
function taskPriorityGet (tid : t_id; pPriority : access int) return int;
pragma Import (C, taskPriorityGet, "taskPriorityGet");
function taskPrioritySet (tid : t_id; newPriority : int) return int;
pragma Import (C, taskPrioritySet, "taskPrioritySet");
- -- Semaphore creation flags.
+ -- Semaphore creation flags
SEM_Q_FIFO : constant := 0;
SEM_Q_PRIORITY : constant := 1;
SEM_EMPTY : constant := 0;
SEM_FULL : constant := 1;
- -- Semaphore take (semTake) time constants.
+ -- Semaphore take (semTake) time constants
WAIT_FOREVER : constant := -1;
NO_WAIT : constant := 0;
- -- Error codes (errno). The lower level 16 bits are the
- -- error code, with the upper 16 bits representing the
- -- module number in which the error occurred. By convention,
- -- the module number is 0 for UNIX errors. VxWorks reserves
- -- module numbers 1-500, with the remaining module numbers
- -- being available for user applications.
+ -- Error codes (errno). The lower level 16 bits are the error code, with
+ -- the upper 16 bits representing the module number in which the error
+ -- occurred. By convention, the module number is 0 for UNIX errors. VxWorks
+ -- reserves module numbers 1-500, with the remaining module numbers being
+ -- available for user applications.
M_objLib : constant := 61 * 2**16;
-- semTake() failure with ticks = NO_WAIT
type SEM_ID is new System.Address;
-- typedef struct semaphore *SEM_ID;
- -- We use two different kinds of VxWorks semaphores: mutex
- -- and binary semaphores. A null ID is returned when
- -- a semaphore cannot be created.
+ -- We use two different kinds of VxWorks semaphores: mutex and binary
+ -- semaphores. A null ID is returned when a semaphore cannot be created.
function semBCreate (options : int; initial_state : int) return SEM_ID;
+ pragma Import (C, semBCreate, "semBCreate");
-- Create a binary semaphore. Return ID, or 0 if memory could not
-- be allocated.
- pragma Import (C, semBCreate, "semBCreate");
function semMCreate (options : int) return SEM_ID;
pragma Import (C, semMCreate, "semMCreate");
function semDelete (Sem : SEM_ID) return int;
- -- Delete a semaphore
pragma Import (C, semDelete, "semDelete");
+ -- Delete a semaphore
function semGive (Sem : SEM_ID) return int;
pragma Import (C, semGive, "semGive");
function semTake (Sem : SEM_ID; timeout : int) return int;
+ pragma Import (C, semTake, "semTake");
-- Attempt to take binary semaphore. Error is returned if operation
-- times out
- pragma Import (C, semTake, "semTake");
function semFlush (SemID : SEM_ID) return STATUS;
- -- Release all threads blocked on the semaphore
pragma Import (C, semFlush, "semFlush");
-
- function taskLock return int;
- pragma Import (C, taskLock, "taskLock");
-
- function taskUnlock return int;
- pragma Import (C, taskUnlock, "taskUnlock");
+ -- Release all threads blocked on the semaphore
private
type sigset_t is new long;
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_Id
+-- ATCB components and types
+
with System.Tasking.Debug;
-- used for Known_Tasks
-- Signal_ID
-- Initialize_Interrupts
-with System.Soft_Links;
--- used for Defer/Undefer_Abort
-
--- Note that we do not use System.Tasking.Initialization directly since
--- this is a higher level package that we shouldn't depend on. For example
--- when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Stages.
-
with System.OS_Interface;
-- used for various type, constant, and operations
with System.Parameters;
-- used for Size_Type
-with System.Tasking;
--- used for Ada_Task_Control_Block
--- Task_Id
--- ATCB components and types
-
with Interfaces.C;
with Unchecked_Conversion;
use System.Parameters;
use type Interfaces.C.int;
- package SSL renames System.Soft_Links;
-
subtype int is System.OS_Interface.int;
Relative : constant := 0;
-- time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
- ATCB_Key : aliased System.Address := System.Null_Address;
- -- Key used to find the Ada Task_Id associated with a thread
-
- ATCB_Key_Addr : System.Address := ATCB_Key'Address;
- pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
- -- Exported to support the temporary AE653 task registration
- -- implementation. This mechanism is used to minimize impact on other
- -- targets.
-
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
- FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
- -- Indicates whether FIFO_Within_Priorities is set
-
Mutex_Protocol : Priority_Type;
Foreign_Task_Elaborated : aliased Boolean := True;
package Specific is
+ procedure Initialize;
+ pragma Inline (Initialize);
+ -- Initialize task specific data
+
function Is_Valid_Task return Boolean;
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
pragma Inline (Set);
-- Set the self id for the current task
+ procedure Delete;
+ pragma Inline (Delete);
+ -- Delete the task specific data associated with the current task
+
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task
procedure Finalize_Lock (L : access Lock) is
Result : int;
-
begin
Result := semDelete (L.Mutex);
pragma Assert (Result = 0);
procedure Finalize_Lock (L : access RTS_Lock) is
Result : int;
-
begin
Result := semDelete (L.Mutex);
pragma Assert (Result = 0);
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : int;
-
begin
if L.Protocol = Prio_Protect
and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
Global_Lock : Boolean := False)
is
Result : int;
-
begin
if not Single_Lock or else Global_Lock then
Result := semTake (L.Mutex, WAIT_FOREVER);
procedure Write_Lock (T : Task_Id) is
Result : int;
-
begin
if not Single_Lock then
Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
------------
procedure Unlock (L : access Lock) is
- Result : int;
-
+ Result : int;
begin
Result := semGive (L.Mutex);
pragma Assert (Result = 0);
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : int;
-
begin
if not Single_Lock or else Global_Lock then
Result := semGive (L.Mutex);
procedure Unlock (T : Task_Id) is
Result : int;
-
begin
if not Single_Lock then
Result := semGive (T.Common.LL.L.Mutex);
-- caller is holding no locks.
procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
is
Orig : constant Duration := Monotonic_Clock;
Absolute : Duration;
Aborted : Boolean := False;
begin
- SSL.Abort_Defer.all;
-
if Mode = Relative then
Absolute := Orig + Time;
Ticks := To_Clock_Ticks (Time);
end if;
-- Take back the lock after having slept, to protect further
- -- access to Self_ID
+ -- access to Self_ID.
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
taskDelay (0);
end if;
-
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
(T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
pragma Assert (Result = 0);
- if FIFO_Within_Priorities then
+ if Dispatching_Policy = 'F' then
-- Annex D requirement [RM D.2.2 par. 9]:
-- Ask for four extra bytes of stack space so that the ATCB pointer can
-- be stored below the stack limit, plus extra space for the frame of
-- Task_Wrapper. This is so the user gets the amount of stack requested
- -- exclusive of the needs
- --
+ -- exclusive of the needs.
+
-- We also have to allocate n more bytes for the task name storage and
-- enough space for the Wind Task Control Block which is around 0x778
-- bytes. VxWorks also seems to carve out additional space, so use 2048
-- as a nice round number. We might want to increment to the nearest
-- page size in case we ever support VxVMI.
- --
- -- XXX - we should come back and visit this so we can set the task name
+
+ -- ??? - we should come back and visit this so we can set the task name
-- to something appropriate.
Adjusted_Stack_Size := Adjusted_Stack_Size + 2048;
Free (Tmp);
if Is_Self then
- Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
- pragma Assert (Result /= ERROR);
+ Specific.Delete;
end if;
end Finalize_TCB;
procedure Initialize (Environment_Task : Task_Id) is
Result : int;
-
begin
+ Environment_Task_Id := Environment_Task;
+
+ Interrupt_Management.Initialize;
+ Specific.Initialize;
+
if Locking_Policy = 'C' then
Mutex_Protocol := Prio_Protect;
elsif Locking_Policy = 'I' then
end if;
if Time_Slice_Val > 0 then
- Result := kernelTimeSlice
+ Result := Set_Time_Slice
(To_Clock_Ticks
(Duration (Time_Slice_Val) / Duration (1_000_000.0)));
end if;
end if;
end loop;
- Environment_Task_Id := Environment_Task;
-
-- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
separate (System.Task_Primitives.Operations)
package body Specific is
+ ATCB_Key : aliased System.Address := System.Null_Address;
+ -- Key used to find the Ada Task_Id associated with a thread
+
+ ATCB_Key_Addr : System.Address := ATCB_Key'Address;
+ pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
+ -- Exported to support the temporary AE653 task registration
+ -- implementation. This mechanism is used to minimize impact on other
+ -- targets.
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete is
+ Result : STATUS;
+ begin
+ Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
+ pragma Assert (Result /= ERROR);
+ end Delete;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
-------------------
-- Is_Valid_Task --
-------------------
projects / platform / upstream / linaro-gcc.git / commitdiff