diff options
| -rw-r--r-- | gcc/ada/adaint.c | 19 | ||||
| -rw-r--r-- | gcc/ada/cal.c | 4 | ||||
| -rw-r--r-- | gcc/ada/expect.c | 2 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-vxworks.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-vxworks.ads | 84 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-vxworks.adb | 85 | ||||
| -rw-r--r-- | gcc/ada/s-tpopsp-vxworks.adb | 29 |
7 files changed, 155 insertions, 99 deletions
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index d5543b92fa4..65fa75bb8c6 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -89,6 +89,8 @@ #if OLD_MINGW #include <sys/wait.h> #endif +#elif defined (__vxworks) && defined (__RTP__) +#include <wait.h> #else #include <sys/wait.h> #endif @@ -1332,6 +1334,9 @@ __gnat_set_env_value (char *name, char *value) LIB$SIGNAL (status); } +#elif defined (__vxworks) && defined (__RTP__) + setenv (name, value, 1); + #else int size = strlen (name) + strlen (value) + 2; char *expression; @@ -1638,11 +1643,12 @@ __gnat_portable_spawn (char *args[]) 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 } @@ -1652,8 +1658,9 @@ __gnat_dup (int oldfd) 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); diff --git a/gcc/ada/cal.c b/gcc/ada/cal.c index 5c72a0c5d9d..7b38e429fcc 100644 --- a/gcc/ada/cal.c +++ b/gcc/ada/cal.c @@ -53,7 +53,11 @@ __gnat_duration_to_timeval (long sec, long usec, void *t) #else #if defined (__vxworks) +#ifdef __RTP__ +#include <time.h> +#else #include <sys/times.h> +#endif #else #include <sys/time.h> #endif diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index 323618e1165..69a3364b6d3 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -49,6 +49,8 @@ #if OLD_MINGW #include <sys/wait.h> #endif +#elif defined (__vxworks) && defined (__RTP__) +#include <wait.h> #else #include <sys/wait.h> #endif diff --git a/gcc/ada/s-osinte-vxworks.adb b/gcc/ada/s-osinte-vxworks.adb index a8b294ffed6..cb8c969c7b0 100644 --- a/gcc/ada/s-osinte-vxworks.adb +++ b/gcc/ada/s-osinte-vxworks.adb @@ -47,6 +47,28 @@ package body System.OS_Interface is 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 -- ------------- @@ -161,4 +183,13 @@ 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; diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads index aa874b98a30..82b4bcee604 100644 --- a/gcc/ada/s-osinte-vxworks.ads +++ b/gcc/ada/s-osinte-vxworks.ads @@ -46,11 +46,11 @@ with System.VxWorks; 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 -- @@ -153,12 +153,11 @@ package System.OS_Interface is 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 -- @@ -183,7 +182,7 @@ package System.OS_Interface is 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; @@ -230,6 +229,15 @@ package System.OS_Interface is 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"); @@ -249,20 +257,26 @@ package System.OS_Interface is 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; @@ -284,8 +298,10 @@ package System.OS_Interface is 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"); @@ -293,7 +309,7 @@ package System.OS_Interface is 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; @@ -305,17 +321,16 @@ package System.OS_Interface is 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 @@ -326,39 +341,32 @@ package System.OS_Interface is 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; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index e955398d7ff..2165ea7f39c 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -40,6 +40,11 @@ pragma Polling (Off); -- 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 @@ -49,25 +54,12 @@ with System.Interrupt_Management; -- 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; @@ -81,8 +73,6 @@ package body System.Task_Primitives.Operations is use System.Parameters; use type Interfaces.C.int; - package SSL renames System.Soft_Links; - subtype int is System.OS_Interface.int; Relative : constant := 0; @@ -99,15 +89,6 @@ package body System.Task_Primitives.Operations is -- 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 @@ -125,9 +106,6 @@ package body System.Task_Primitives.Operations is 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; @@ -139,6 +117,10 @@ package body System.Task_Primitives.Operations is 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? @@ -147,6 +129,10 @@ package body System.Task_Primitives.Operations is 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 @@ -298,7 +284,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access Lock) is Result : int; - begin Result := semDelete (L.Mutex); pragma Assert (Result = 0); @@ -306,7 +291,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access RTS_Lock) is Result : int; - begin Result := semDelete (L.Mutex); pragma Assert (Result = 0); @@ -318,7 +302,6 @@ package body System.Task_Primitives.Operations is 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 @@ -338,7 +321,6 @@ package body System.Task_Primitives.Operations is Global_Lock : Boolean := False) is Result : int; - begin if not Single_Lock or else Global_Lock then Result := semTake (L.Mutex, WAIT_FOREVER); @@ -348,7 +330,6 @@ package body System.Task_Primitives.Operations is procedure Write_Lock (T : Task_Id) is Result : int; - begin if not Single_Lock then Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); @@ -370,8 +351,7 @@ package body System.Task_Primitives.Operations is ------------ procedure Unlock (L : access Lock) is - Result : int; - + Result : int; begin Result := semGive (L.Mutex); pragma Assert (Result = 0); @@ -379,7 +359,6 @@ package body System.Task_Primitives.Operations is 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); @@ -389,7 +368,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (T : Task_Id) is Result : int; - begin if not Single_Lock then Result := semGive (T.Common.LL.L.Mutex); @@ -568,9 +546,9 @@ package body System.Task_Primitives.Operations is -- 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; @@ -580,8 +558,6 @@ package body System.Task_Primitives.Operations is Aborted : Boolean := False; begin - SSL.Abort_Defer.all; - if Mode = Relative then Absolute := Orig + Time; Ticks := To_Clock_Ticks (Time); @@ -654,7 +630,7 @@ package body System.Task_Primitives.Operations is 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); @@ -678,8 +654,6 @@ package body System.Task_Primitives.Operations is else taskDelay (0); end if; - - SSL.Abort_Undefer.all; end Timed_Delay; --------------------- @@ -754,7 +728,7 @@ package body System.Task_Primitives.Operations is (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]: @@ -905,15 +879,15 @@ package body System.Task_Primitives.Operations is -- 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; @@ -990,8 +964,7 @@ package body System.Task_Primitives.Operations is Free (Tmp); if Is_Self then - Result := taskVarDelete (taskIdSelf, ATCB_Key'Access); - pragma Assert (Result /= ERROR); + Specific.Delete; end if; end Finalize_TCB; @@ -1249,8 +1222,12 @@ package body System.Task_Primitives.Operations is 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 @@ -1260,7 +1237,7 @@ package body System.Task_Primitives.Operations is 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; @@ -1275,8 +1252,6 @@ package body System.Task_Primitives.Operations is 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); diff --git a/gcc/ada/s-tpopsp-vxworks.adb b/gcc/ada/s-tpopsp-vxworks.adb index 86414d63e25..e05ed7df611 100644 --- a/gcc/ada/s-tpopsp-vxworks.adb +++ b/gcc/ada/s-tpopsp-vxworks.adb @@ -38,6 +38,35 @@ 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 -- ------------------- |