s-taprop-vxworks.adb: Move with clauses outside Warnings Off now that dependent…

s-taprop-vxworks.adb: Move with clauses outside Warnings Off now that dependent units are Preelaborate.

2005-09-01  Arnaud Charlet  <charlet@adacore.com>
	    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.

From-SVN: r103852

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);

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

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

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;

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;

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);

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 --
    -------------------