path: root/gcc/ada/5zosinte.adb

------------------------------------------------------------------------------
--                                                                          --
--                 GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS              --
--                                                                          --
--                   S Y S T E M . O S _ I N T E R F A C E                  --
--                                                                          --
--                                   B o d y                                --
--                                                                          --
--                             $Revision: 1.15 $
--                                                                          --
--             Copyright (C) 1997-2001 Free Software Foundation             --
--                                                                          --
-- 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- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNARL; see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com).                                  --
--                                                                          --
------------------------------------------------------------------------------

--  This is the VxWorks version.

--  This package encapsulates all direct interfaces to OS services
--  that are needed by children of System.

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 Interfaces.C; use Interfaces.C;

with System.VxWorks;
--  used for Wind_TCB_Ptr

with Unchecked_Conversion;

package body System.OS_Interface is

   use System.VxWorks;

   --  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 taskSpawn
     (name          : System.Address;  --  Pointer to task name
      priority      : int;
      options       : int;
      stacksize     : size_t;
      start_routine : Thread_Body;
      arg1          : System.Address;
      arg2          : int := 0;
      arg3          : int := 0;
      arg4          : int := 0;
      arg5          : int := 0;
      arg6          : int := 0;
      arg7          : int := 0;
      arg8          : int := 0;
      arg9          : int := 0;
      arg10         : int := 0) return pthread_t;
   pragma Import (C, taskSpawn, "taskSpawn");

   procedure taskDelete (tid : pthread_t);
   pragma Import (C, taskDelete, "taskDelete");

   --  These are the POSIX scheduling priorities. These are enabled
   --  when the global variable posixPriorityNumbering is 1.

   POSIX_SCHED_FIFO_LOW_PRI  : constant := 0;
   POSIX_SCHED_FIFO_HIGH_PRI : constant := 255;
   POSIX_SCHED_RR_LOW_PRI    : constant := 0;
   POSIX_SCHED_RR_HIGH_PRI   : constant := 255;

   --  These are the VxWorks native (default) scheduling priorities.
   --  These are used when the global variable posixPriorityNumbering
   --  is 0.

   SCHED_FIFO_LOW_PRI  : constant := 255;
   SCHED_FIFO_HIGH_PRI : constant := 0;
   SCHED_RR_LOW_PRI    : constant := 255;
   SCHED_RR_HIGH_PRI   : constant := 0;

   --  Global variable to enable POSIX priority numbering.
   --  By default, it is 0 and VxWorks native priority numbering
   --  is used.

   posixPriorityNumbering : int;
   pragma Import (C, posixPriorityNumbering, "posixPriorityNumbering");

   --  VxWorks will let you set round-robin scheduling globally
   --  for all tasks, but not for individual tasks.  Attempting
   --  to set the scheduling policy for a specific task (using
   --  sched_setscheduler) to something other than what the system
   --  is currently using will fail.  If you wish to change the
   --  scheduling policy, then use the following function to set
   --  it globally for all tasks.  When ticks is 0, time slicing
   --  (round-robin scheduling) is disabled.

   function kernelTimeSlice (ticks : int) return int;
   pragma Import (C, kernelTimeSlice, "kernelTimeSlice");

   function taskPriorityGet
     (tid       : pthread_t;
      pPriority : access int)
     return int;
   pragma Import (C, taskPriorityGet, "taskPriorityGet");

   function taskPrioritySet
     (tid         : pthread_t;
      newPriority : int)
     return int;
   pragma Import (C, taskPrioritySet, "taskPrioritySet");

   function To_Wind_TCB_Ptr is
     new Unchecked_Conversion (pthread_t, Wind_TCB_Ptr);


   --  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
   S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2;
   --  semTake() timeout with ticks > NO_WAIT
   S_objLib_OBJ_TIMEOUT     : constant := M_objLib + 4;

   --  We use two different kinds of VxWorks semaphores: mutex
   --  and binary semaphores.  A null (0) ID is returned when
   --  a semaphore cannot be created. Binary semaphores and common
   --  operations are declared in the spec of this package,
   --  as they are used to implement hardware interrupt handling

   function semMCreate
     (options : int) return SEM_ID;
   pragma Import (C, semMCreate, "semMCreate");


   function taskLock return int;
   pragma Import (C, taskLock, "taskLock");

   function taskUnlock return int;
   pragma Import (C, taskUnlock, "taskUnlock");

   -------------------------------------------------------
   --  Convenience routines to convert between VxWorks  --
   --  priority and POSIX priority.                     --
   -------------------------------------------------------

   function To_Vxworks_Priority (Priority : in int) return int;
   pragma Inline (To_Vxworks_Priority);

   function To_Posix_Priority (Priority : in int) return int;
   pragma Inline (To_Posix_Priority);

   function To_Vxworks_Priority (Priority : in int) return int is
   begin
      return SCHED_FIFO_LOW_PRI - Priority;
   end To_Vxworks_Priority;

   function To_Posix_Priority (Priority : in int) return int is
   begin
      return SCHED_FIFO_LOW_PRI - Priority;
   end To_Posix_Priority;

   ----------------------------------------
   --  Implementation of POSIX routines  --
   ----------------------------------------

   -----------------------------------------
   --  Nonstandard Thread Initialization  --
   -----------------------------------------

   procedure pthread_init is
   begin
      Keys_Created := 0;
      Time_Slice := -1;
   end pthread_init;

   ---------------------------
   --  POSIX.1c  Section 3  --
   ---------------------------

   function sigwait
     (set : access sigset_t;
      sig : access Signal) return int
   is
      Result  : Interfaces.C.int;

      function sigwaitinfo
        (set : access sigset_t; sigvalue : System.Address) return int;
      pragma Import (C, sigwaitinfo, "sigwaitinfo");

   begin
      Result := sigwaitinfo (set, System.Null_Address);

      if Result /= -1 then
         sig.all := Signal (Result);
         return 0;
      else
         sig.all := 0;
         return errno;
      end if;
   end sigwait;

   ----------------------------
   --  POSIX.1c  Section 11  --
   ----------------------------

   function pthread_mutexattr_init
     (attr : access pthread_mutexattr_t) return int is
   begin
      --  Let's take advantage of VxWorks priority inversion
      --  protection.
      --
      --  ??? - Do we want to also specify SEM_DELETE_SAFE???

      attr.Flags := int (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);

      --  Initialize the ceiling priority to the maximim priority.
      --  We will use POSIX priorities since these routines are
      --  emulating POSIX routines.

      attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
      attr.Protocol := PTHREAD_PRIO_INHERIT;
      return 0;
   end pthread_mutexattr_init;

   function pthread_mutexattr_destroy
     (attr : access pthread_mutexattr_t) return int is
   begin
      attr.Flags := 0;
      attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
      attr.Protocol := PTHREAD_PRIO_INHERIT;
      return 0;
   end pthread_mutexattr_destroy;

   function pthread_mutex_init
     (mutex : access pthread_mutex_t;
      attr  : access pthread_mutexattr_t) return int
   is
      Result : int := 0;

   begin
      --  A mutex should initially be created full and the task
      --  protected from deletion while holding the semaphore.

      mutex.Mutex := semMCreate (attr.Flags);
      mutex.Prio_Ceiling := attr.Prio_Ceiling;
      mutex.Protocol := attr.Protocol;

      if mutex.Mutex = 0 then
         Result := errno;
      end if;

      return Result;
   end pthread_mutex_init;

   function pthread_mutex_destroy
     (mutex : access pthread_mutex_t) return int
   is
      Result : STATUS;
   begin
      Result := semDelete (mutex.Mutex);

      if Result /= 0 then
         Result := errno;
      end if;

      mutex.Mutex := 0;  --  Ensure the mutex is properly cleaned.
      mutex.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
      mutex.Protocol := PTHREAD_PRIO_INHERIT;
      return Result;
   end pthread_mutex_destroy;

   function pthread_mutex_lock
     (mutex : access pthread_mutex_t) return int
   is
      Result    : int;
      WTCB_Ptr  : Wind_TCB_Ptr;
   begin
      WTCB_Ptr := To_Wind_TCB_Ptr (taskIdSelf);

      if WTCB_Ptr = null then
         return errno;
      end if;

      --  Check the current inherited priority in the WIND_TCB
      --  against the mutex ceiling priority and return EINVAL
      --  upon a ceiling violation.
      --
      --  We always convert the VxWorks priority to POSIX priority
      --  in case the current priority ordering has changed (see
      --  posixPriorityNumbering).  The mutex ceiling priority is
      --  maintained as POSIX compatible.

      if mutex.Protocol = PTHREAD_PRIO_PROTECT and then
         To_Posix_Priority (WTCB_Ptr.Priority) > mutex.Prio_Ceiling
      then
         return EINVAL;
      end if;

      Result := semTake (mutex.Mutex, WAIT_FOREVER);

      if Result /= 0 then
         Result := errno;
      end if;

      return Result;
   end pthread_mutex_lock;

   function pthread_mutex_unlock
     (mutex : access pthread_mutex_t) return int
   is
      Result : int;
   begin
      Result := semGive (mutex.Mutex);

      if Result /= 0 then
         Result := errno;
      end if;

      return Result;
   end pthread_mutex_unlock;

   function pthread_condattr_init
     (attr : access pthread_condattr_t) return int is
   begin
      attr.Flags := SEM_Q_PRIORITY;
      return 0;
   end pthread_condattr_init;

   function pthread_condattr_destroy
     (attr : access pthread_condattr_t) return int is
   begin
      attr.Flags := 0;
      return 0;
   end pthread_condattr_destroy;

   function pthread_cond_init
     (cond : access pthread_cond_t;
      attr : access pthread_condattr_t) return int
   is
      Result  : int := 0;

   begin
      --  Condition variables should be initially created
      --  empty.

      cond.Sem := semBCreate (attr.Flags, SEM_EMPTY);
      cond.Waiting := 0;

      if cond.Sem = 0 then
         Result := errno;
      end if;

      return Result;
   end pthread_cond_init;

   function pthread_cond_destroy (cond : access pthread_cond_t) return int is
      Result : int;

   begin
      Result := semDelete (cond.Sem);

      if Result /= 0 then
         Result := errno;
      end if;

      return Result;
   end pthread_cond_destroy;

   function pthread_cond_signal
     (cond : access pthread_cond_t) return int
   is
      Result : int := 0;
      Status : int;

   begin
      --  Disable task scheduling.

      Status := taskLock;

      --  Iff someone is currently waiting on the condition variable
      --  then release the semaphore; we don't want to leave the
      --  semaphore in the full state because the next guy to do
      --  a condition wait operation would not block.

      if cond.Waiting > 0 then
         Result := semGive (cond.Sem);

         --  One less thread waiting on the CV.

         cond.Waiting := cond.Waiting - 1;

         if Result /= 0 then
            Result := errno;
         end if;
      end if;

      --  Reenable task scheduling.

      Status := taskUnlock;

      return Result;
   end pthread_cond_signal;

   function pthread_cond_wait
     (cond  : access pthread_cond_t;
      mutex : access pthread_mutex_t) return int
   is
      Result : int;
      Status : int;
   begin
      --  Disable task scheduling.

      Status := taskLock;

      --  Release the mutex as required by POSIX.

      Result := semGive (mutex.Mutex);

      --  Indicate that there is another thread waiting on the CV.

      cond.Waiting := cond.Waiting + 1;

      --  Perform a blocking operation to take the CV semaphore.
      --  Note that a blocking operation in VxWorks will reenable
      --  task scheduling.  When we are no longer blocked and control
      --  is returned, task scheduling will again be disabled.

      Result := semTake (cond.Sem, WAIT_FOREVER);

      if Result /= 0 then
         cond.Waiting := cond.Waiting - 1;
         Result := EINVAL;
      end if;

      --  Take the mutex as required by POSIX.

      Status := semTake (mutex.Mutex, WAIT_FOREVER);

      if Status /= 0 then
         Result := EINVAL;
      end if;

      --  Reenable task scheduling.

      Status := taskUnlock;

      return Result;
   end pthread_cond_wait;

   function pthread_cond_timedwait
     (cond    : access pthread_cond_t;
      mutex   : access pthread_mutex_t;
      abstime : access timespec) return int
   is
      Result  : int;
      Status  : int;
      Ticks   : int;
      TS      : aliased timespec;
   begin
      Status := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);

      --  Calculate the number of clock ticks for the timeout.

      Ticks := To_Clock_Ticks (To_Duration (abstime.all) - To_Duration (TS));

      if Ticks <= 0 then
         --  It is not worth the time to try to perform a semTake,
         --  because we know it will always fail.  A semTake with
         --  ticks = 0 (NO_WAIT) will not block and therefore not
         --  allow another task to give the semaphore.  And if we've
         --  designed pthread_cond_signal correctly, the semaphore
         --  should never be left in a full state.
         --
         --  Make sure we give up the CPU.

         Status := taskDelay (0);
         return ETIMEDOUT;
      end if;

      --  Disable task scheduling.

      Status := taskLock;

      --  Release the mutex as required by POSIX.

      Result := semGive (mutex.Mutex);

      --  Indicate that there is another thread waiting on the CV.

      cond.Waiting := cond.Waiting + 1;

      --  Perform a blocking operation to take the CV semaphore.
      --  Note that a blocking operation in VxWorks will reenable
      --  task scheduling.  When we are no longer blocked and control
      --  is returned, task scheduling will again be disabled.

      Result := semTake (cond.Sem, Ticks);

      if Result /= 0 then
         if errno = S_objLib_OBJ_TIMEOUT then
            Result := ETIMEDOUT;
         else
            Result := EINVAL;
         end if;
         cond.Waiting := cond.Waiting - 1;
      end if;

      --  Take the mutex as required by POSIX.

      Status := semTake (mutex.Mutex, WAIT_FOREVER);

      if Status /= 0 then
         Result := EINVAL;
      end if;

      --  Reenable task scheduling.

      Status := taskUnlock;

      return Result;
   end pthread_cond_timedwait;

   ----------------------------
   --  POSIX.1c  Section 13  --
   ----------------------------

   function pthread_mutexattr_setprotocol
     (attr     : access pthread_mutexattr_t;
      protocol : int) return int is
   begin
      if protocol < PTHREAD_PRIO_NONE
        or protocol > PTHREAD_PRIO_PROTECT
      then
         return EINVAL;
      end if;

      attr.Protocol := protocol;
      return 0;
   end pthread_mutexattr_setprotocol;

   function pthread_mutexattr_setprioceiling
     (attr        : access pthread_mutexattr_t;
      prioceiling : int) return int is
   begin
      --  Our interface to the rest of the world is meant
      --  to be POSIX compliant; keep the priority in POSIX
      --  format.

      attr.Prio_Ceiling := prioceiling;
      return 0;
   end pthread_mutexattr_setprioceiling;

   function pthread_setschedparam
     (thread : pthread_t;
      policy : int;
      param  : access struct_sched_param) return int
   is
      Result : int;
   begin
      --  Convert the POSIX priority to VxWorks native
      --  priority.

      Result := taskPrioritySet (thread,
        To_Vxworks_Priority (param.sched_priority));
      return 0;
   end pthread_setschedparam;

   function sched_yield return int is
   begin
      return taskDelay (0);
   end sched_yield;

   function pthread_sched_rr_set_interval (usecs : int) return int is
      Result  : int := 0;
      D_Slice : Duration;
   begin
      --  Check to see if round-robin scheduling (time slicing)
      --  is enabled.  If the time slice is the default value (-1)
      --  or any negative number, we will leave the kernel time
      --  slice unchanged.  If the time slice is 0, we disable
      --  kernel time slicing by setting it to 0.  Otherwise, we
      --  set the kernel time slice to the specified value converted
      --  to clock ticks.

      Time_Slice := usecs;

      if Time_Slice > 0 then
         D_Slice := Duration (Time_Slice) / Duration (1_000_000.0);
         Result := kernelTimeSlice (To_Clock_Ticks (D_Slice));

      else
         if Time_Slice = 0 then
            Result := kernelTimeSlice (0);
         end if;
      end if;

      return Result;
   end pthread_sched_rr_set_interval;

   function pthread_attr_init (attr : access pthread_attr_t) return int is
   begin
      attr.Stacksize := 100000;   -- What else can I do?
      attr.Detachstate := PTHREAD_CREATE_DETACHED;
      attr.Priority := POSIX_SCHED_FIFO_LOW_PRI;
      attr.Taskname := System.Null_Address;
      return 0;
   end pthread_attr_init;

   function pthread_attr_destroy (attr : access pthread_attr_t) return int is
   begin
      attr.Stacksize := 0;
      attr.Detachstate := 0;
      attr.Priority := POSIX_SCHED_FIFO_LOW_PRI;
      attr.Taskname := System.Null_Address;
      return 0;
   end pthread_attr_destroy;

   function pthread_attr_setdetachstate
     (attr        : access pthread_attr_t;
      detachstate : int) return int is
   begin
      attr.Detachstate := detachstate;
      return 0;
   end pthread_attr_setdetachstate;

   function pthread_attr_setstacksize
     (attr      : access pthread_attr_t;
      stacksize : size_t) return int is
   begin
      attr.Stacksize := stacksize;
      return 0;
   end pthread_attr_setstacksize;

   --  In VxWorks tasks, we can set the task name.  This
   --  makes it really convenient for debugging.

   function pthread_attr_setname_np
     (attr : access pthread_attr_t;
      name : System.Address) return int is
   begin
      attr.Taskname := name;
      return 0;
   end pthread_attr_setname_np;

   function pthread_create
     (thread        : access pthread_t;
      attr          : access pthread_attr_t;
      start_routine : Thread_Body;
      arg           : System.Address) return int is
   begin
      thread.all := taskSpawn (attr.Taskname,
        To_Vxworks_Priority (attr.Priority), VX_FP_TASK, attr.Stacksize,
        start_routine, arg);

      if thread.all = -1 then
         return -1;
      else
         return 0;
      end if;
   end pthread_create;

   function pthread_detach (thread : pthread_t) return int is
   begin
      return 0;
   end pthread_detach;

   procedure pthread_exit (status : System.Address) is
   begin
      taskDelete (0);
   end pthread_exit;

   function pthread_self return pthread_t is
   begin
      return taskIdSelf;
   end pthread_self;

   function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int is
   begin
      if t1 = t2 then
         return 1;
      else
         return 0;
      end if;
   end pthread_equal;

   function pthread_setspecific
     (key   : pthread_key_t;
      value : System.Address) return int
   is
      Result : int;
   begin
      if Integer (key) not in Key_Storage'Range then
         return EINVAL;
      end if;

      Key_Storage (Integer (key)) := value;
      Result := taskVarAdd (taskIdSelf, Key_Storage (Integer (key))'Access);

      --  We should be able to directly set the key with the following:
      --     Key_Storage (key) := value;
      --  but we'll be safe and use taskVarSet.
      --  ??? Come back and revisit this.

      Result := taskVarSet (taskIdSelf,
        Key_Storage (Integer (key))'Access, value);
      return Result;
   end pthread_setspecific;

   function pthread_getspecific (key : pthread_key_t) return System.Address is
   begin
      return Key_Storage (Integer (key));
   end pthread_getspecific;

   function pthread_key_create
     (key        : access pthread_key_t;
      destructor : destructor_pointer) return int is
   begin
      Keys_Created := Keys_Created + 1;

      if Keys_Created not in Key_Storage'Range then
         return ENOMEM;
      end if;

      key.all := pthread_key_t (Keys_Created);
      return 0;
   end pthread_key_create;

   -----------------
   -- To_Duration --
   -----------------

   function To_Duration (TS : timespec) return Duration is
   begin
      return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
   end To_Duration;

   -----------------
   -- To_Timespec --
   -----------------

   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 < 0.0 then
         S := S - 1;
         F := F + 1.0;
      end if;
      return timespec' (ts_sec => S,
        ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
   end To_Timespec;

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

   function To_Clock_Ticks (D : Duration) return int is
      Ticks          : Long_Long_Integer;
      Rate_Duration  : Duration;
      Ticks_Duration : Duration;
   begin

      --  Ensure that the duration can be converted to ticks
      --  at the current clock tick rate without overflowing.

      Rate_Duration := Duration (sysClkRateGet);

      if D > (Duration'Last / Rate_Duration) then
         Ticks := Long_Long_Integer (int'Last);

      else
         --  We always want to round up to the nearest clock tick.

         Ticks_Duration := D * Rate_Duration;
         Ticks := Long_Long_Integer (Ticks_Duration);

         if Ticks_Duration > Duration (Ticks) then
            Ticks := Ticks + 1;
         end if;

         if Ticks > Long_Long_Integer (int'Last) then
            Ticks := Long_Long_Integer (int'Last);
         end if;
      end if;

      return int (Ticks);
   end To_Clock_Ticks;

end System.OS_Interface;