------------------------------------------------------------------------------
--                                                                          --
--                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
--                                                                          --
--     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
--                                                                          --
--                                  B o d y                                 --
--                         (Version for new GNARL)                          --
--                                                                          --
--                             $Revision: 1.14 $                            --
--                                                                          --
--   Copyright (C) 1991,1992,1993,1994,1995,1996 Florida State University   --
--                                                                          --
-- 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 a Solaris version of this package.

--  DO NOT EDIT this file.
--  It was automatically generated from another file by the m4 macro processor.
--  The name of the file you should edit is the same as this one, but with
--  ".ads" replaced by ".sm4", or
--  ".adb" replaced by ".bm4", or
--  ".c" replaced by ".cm4", or
--  ".dat" replaced by ".tm4"

--  Local options selected:
--    __TARGET            = sparc-sun-solaris2
--    __ARCH              = SPARC
--    __OS                = SUNOS5X
--    __HAS_SIGCONTEXT    = 0
--    __HAS_UCONTEXT      = 1
--    __THREADS           = SOLARIS_THREADS
--    __THREAD_VARIANT    = NA
--    __HAS_TIMESPEC      = 1
--    __HAS_NANOSLEEP     = 1
--    __HAS_CLOCK_GETTIME = 1
--    __HAS_GETTIMEOFDAY  = 1
--    __POSIX_THREAD_PRIO_PROTECT = 0
--    __POSIX_THREAD_PRIO_INHERIT = 0
--    __POSIX_THREAD_ATTR_STACKADDR = 0
--    __POSIX_THREAD_ATTR_STACKSIZE = 0
--    __POSIX_THREAD_PRIORITY_SCHEDULING = 0

with Interfaces.C;
--  used for int
--           size_t

with System.Error_Reporting;
--  used for Shutdown

with System.Interrupt_Management;
--  used for Keep_Unmasked
--           Abort_Task_Interrupt
--           Interrupt_ID

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

with System.Time_Operations;
--  used for Clock
--           Clock_Delay_Correction

with Unchecked_Conversion;
with Unchecked_Deallocation;

package body System.Task_Primitives.Operations is

   use System.Tasking;
   use Interfaces.C;
   use System.Error_Reporting;
   use System.OS_Interface;
   use System.Parameters;
   use Time_Operations;

   ------------------
   --  Local Data  --
   ------------------

   --  The followings are logically constants, but need to be initialized
   --  at run time.

   Environmental_Task_ID : Task_ID;
   --  A variable to hold Task_ID for the environmental task.
   --  If we use this variable to get the Task_ID, we do not need the following
   --  ATCB_Key. %%%%%

   --  ATCB_Key : aliased thread_key_t;
   --  Key used to find the Ada Task_ID associated with a thread

   All_Signal_Mask,
   --  The set of all signals

   Unblocked_Signal_Mask : aliased sigset_t;
   --  The set of signals that should unblocked in all tasks

   --  The followings are internal configuration constants needed.

   Default_Stack_Size : constant Interfaces.C.size_t := 0;

   Minimum_Stack_Size : constant Interfaces.C.size_t := thr_min_stack;

   Is_Priority_Supported : Boolean := false;
   --  Flag to be set in the initializaiton of this package and used in
   --  Set_Priority. If priority is not supported then don't bother setting
   --  them!

   Class_Info : struct_pcinfo;
   --  Hold class info (Real_Time) intialized during the package elaboration.

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Abort_Handler
     (Sig     : Signal;
      Code    : access siginfo_t;
      Context : access ucontext_t);

   function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);

   function To_Address is new Unchecked_Conversion (Task_ID, System.Address);

   -------------------
   -- Abort_Handler --
   -------------------

   --  Target-dependent binding of inter-thread Abort signal to
   --  the raising of the Abort_Signal exception.

   --  The technical issues and alternatives here are essentially
   --  the same as for raising exceptions in response to other
   --  signals (e.g. Storage_Error).  See code and comments in
   --  the package body System.Interrupt_Management.

   --  Some implementations may not allow an exception to be propagated
   --  out of a handler, and others might leave the signal or
   --  interrupt that invoked this handler masked after the exceptional
   --  return to the application code.

   --  GNAT exceptions are originally implemented using setjmp()/longjmp().
   --  On most UNIX systems, this will allow transfer out of a signal handler,
   --  which is usually the only mechanism available for implementing
   --  asynchronous handlers of this kind.  However, some
   --  systems do not restore the signal mask on longjmp(), leaving the
   --  abort signal masked.

   --  Alternative solutions include:

   --       1. Change the PC saved in the system-dependent Context
   --          parameter to point to code that raises the exception.
   --          Normal return from this handler will then raise
   --          the exception after the mask and other system state has
   --          been restored (see example below).
   --       2. Use siglongjmp()/sigsetjmp() to implement exceptions.
   --       3. Unmask the signal in the Abortion_Signal exception handler
   --          (in the RTS).

   --  The following procedure would be needed if we can't lonjmp out of
   --  a signal handler.  (See below.)
   --  procedure Raise_Abort_Signal is
   --  begin
   --     raise Standard'Abort_Signal;
   --  end if;

   procedure Abort_Handler
     (Sig     : Signal;
      Code    : access siginfo_t;
      Context : access ucontext_t) is

      T : Task_ID := Self;

   begin
      --  Assuming it is safe to longjmp out of a signal handler, the
      --  following code can be used:

      if T.Deferral_Level = 0
        and then T.Pending_ATC_Level < T.ATC_Nesting_Level then
         raise Standard'Abort_Signal;
      end if;

      --  Otherwise, something like this is required:
      --  if not Abort_Is_Deferred.all then
      --    --  Overwrite the return PC address with the address of the
      --    --  special raise routine, and "return" to that routine's
      --    --  starting address.
      --    Context.PC := Raise_Abort_Signal'Address;
      --    return;
      --  end if;

   end Abort_Handler;

   ----------
   -- Self --
   ----------

   --  For Solaris version of RTS, we use a short cut to get the self
   --  information faster:
   --  We have noticed that on Sparc Solaris, the register g7 always
   --  contains the address near the frame pointer (fp) of the active
   --  thread (fixed offset). This means, if we declare a variable near
   --  the top of the stack for each threads (in our case in the task wrapper)
   --  and let the variable hold the Task_ID information, we can get the
   --  value without going through the thr_getspecific kernel call.
   --
   --  There are two things to take care in this trick.
   --
   --  1) We need to calculate the offset between the g7 value and the
   --     local variable address.
   --     Possible Solutions :
   --        a) Use gdb to figure out the offset.
   --        b) Figure it out during the elaboration of RTS by, say,
   --           creating a dummy task .....
   --     We used solution a) mainly because it is more efficient and keep
   --     the RTS being messed up with some stuff that most other system
   --     won't be using. (i.e. we may have to at least introduce dummy
   --     interfaces.... to do a specific thing for a specific target).
   --
   --     On Sparc Solaris the offset is #10#108# (= #16#6b#).
   --
   --  2) We can not use the same offset business for the main thread
   --     because we do not use a wrapper for the main thread.
   --     So, we use a global variable to store the Task_ID. The trick is
   --     to figure out if we need to use the value only looking at the
   --     contents of the g7 register. In Solaris2.4, g7 contains an address
   --     close to fp register (g7 > fp) when the control is in a thread
   --     other than the main thread. Therefore we use the diffenence
   --     between g7 and fp to get the infomation we need.
   --
   --  NOTE: What we are doing here is ABSOLUTELY for Solaris 2.4!!!!!!!
   --        We need to make sure this is OK when we move to other versions
   --        of the same OS.
   --        We always can go back to the old way of doing this and we include
   --        the code which use thr_getspecifics. Also, look for %%%%%
   --        in comments for other necessary modifications.

   --  function Self return Task_ID is
   --     Temp   : aliased System.Address;
   --     Result : Interfaces.C.int;
   --  begin
   --     Result := thr_getspecific (ATCB_Key, Temp'Unchecked_Access);
   --     pragma Assert (Result = 0
   --       or else Shutdown ("GNULLI failure---thr_getspecific"));
   --     return To_Task_ID (Temp);
   --  end Self;

   function Self return Task_ID is

      function Get_G7 return Interfaces.C.Unsigned;
      pragma Import (C, Get_G7, "get_g7");

      function Get_I6 return Interfaces.C.Unsigned;
      pragma Import (C, Get_I6, "get_i6");

      G7 : Interfaces.C.Unsigned := Get_G7;

      type Ptr is access Task_ID;
      function To_Ptr is new Unchecked_Conversion (Interfaces.C.Unsigned, Ptr);
      X : Ptr;

   begin
      if G7 - Get_I6 > 16#10000# then
      --  if the difference of these two regs are big, we can say the
      --  content of g7 indicates that we are in the main thread.
         return Environmental_Task_ID;
      end if;

      G7 := G7 - 108;
      X := To_Ptr (G7);

      return X.all;

   end Self;

   ---------------------
   -- Initialize_Lock --
   ---------------------

   --  Note: mutexes and cond_variables needed per-task basis are
   --        initialized in Intialize_TCB and the Storage_Error is
   --        handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
   --        used in RTS is initialized before any status change of RTS.
   --        Therefore rasing Storage_Error in the following routines
   --        should be able to be handled safely.

   procedure Initialize_Lock
     (Prio : System.Any_Priority;
      L    : access Lock)
   is
      Result : Interfaces.C.int;

   begin
      Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
      pragma Assert (Result = 0 or else Result = ENOMEM
           or else Shutdown ("GNULLI failure---mutex_init"));
      if Result = ENOMEM then
         raise STORAGE_ERROR;
      end if;

      L.Prio_Save := 0;
      L.Prio := Interfaces.C.Int (Prio);
   end Initialize_Lock;

   procedure Initialize_Lock (L : access RTS_Lock) is
      Result : Interfaces.C.int;

   begin
      Result := mutex_init (L, USYNC_THREAD, System.Null_Address);
      pragma Assert (Result = 0 or else Result = ENOMEM
           or else Shutdown ("GNULLI failure---mutex_init"));
      if Result = ENOMEM then
         raise STORAGE_ERROR;
      end if;
   end Initialize_Lock;

   -------------------
   -- Finalize_Lock --
   -------------------

   procedure Finalize_Lock (L : access Lock) is
      Result : Interfaces.C.int;

   begin
      Result := mutex_destroy (L.L'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---mutex_destroy"));
   end Finalize_Lock;

   procedure Finalize_Lock (L : access RTS_Lock) is
      Result : Interfaces.C.int;

   begin
      Result := mutex_destroy (L);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---mutex_destroy"));
   end Finalize_Lock;

   ----------------
   -- Write_Lock --
   ----------------

   procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
      Self_ID      : Task_ID;
      Current_Prio : System.Any_Priority;
      Result       : Interfaces.C.int;

   begin
      if not Is_Priority_Supported then
         Result := mutex_lock (L.L'Access);
         pragma Assert (Result = 0 or else
           Shutdown ("GNULLI failure---mutex_lock"));
         Ceiling_Violation := False;
         return;
      end if;

      Self_ID := Self;
      Current_Prio := Get_Priority (Self_ID);

      if L.Prio < Interfaces.C.Int (Current_Prio) then
         Ceiling_Violation := True;
         return;
      end if;

      Ceiling_Violation := False;
      L.Prio_Save := Interfaces.C.int (Current_Prio);
      Set_Priority (Self_ID, System.Any_Priority (L.Prio));
   end Write_Lock;

   procedure Write_Lock (L : access RTS_Lock) is
      Result : Interfaces.C.int;

   begin
      Result := mutex_lock (L);
      pragma Assert (Result = 0
          or else Shutdown ("GNULLI failure---mutex_lock"));
   end Write_Lock;

   procedure Write_Lock (T : Task_ID) is
      Result : Interfaces.C.int;

   begin
      Result := mutex_lock (T.LL.L'Access);
      pragma Assert (Result = 0
          or else Shutdown ("GNULLI failure---mutex_lock"));
   end Write_Lock;

   ---------------
   -- Read_Lock --
   ---------------

   procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
   begin
      Write_Lock (L, Ceiling_Violation);
   end Read_Lock;

   ------------
   -- Unlock --
   ------------

   procedure Unlock (L : access Lock) is
      Self_ID : Task_ID := Self;
      Result  : Interfaces.C.int;
   begin
      Result := mutex_unlock (L.L'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---mutex_unlock"));
      if Is_Priority_Supported then
         Set_Priority (Self_ID, System.Any_Priority (L.Prio_Save));
      end if;
   end Unlock;

   procedure Unlock (L : access RTS_Lock) is
      Result : Interfaces.C.int;

   begin
      Result := mutex_unlock (L);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---mutex_unlock"));
   end Unlock;

   procedure Unlock (T : Task_ID) is
      Result : Interfaces.C.int;

   begin
      Result := mutex_unlock (T.LL.L'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---mutex_unlock"));
   end Unlock;

   -------------
   --  Sleep  --
   -------------

   procedure Sleep (Self_ID : Task_ID) is
      Result : Interfaces.C.int;

   begin
      pragma Assert (Self_ID = Self
        or else Shutdown ("GNULLI failure---Self in Sleep"));
      Result := cond_wait (Self_ID.LL.CV'Access, Self_ID.LL.L'Access);
      --  EINTR is not considered a failure.
      pragma Assert (Result = 0 or else Result = EINTR
        or else Shutdown ("GNULLI failure---Sleep"));
   end Sleep;

   ---------------
   -- Sleep_For --
   ---------------

   procedure Sleep_For (Self_ID : Task_ID; Rel_Time : Duration) is
      Result : Interfaces.C.int;
      Request : aliased timespec;

   begin
      pragma Assert (Self_ID = Self
        or else Shutdown ("GNULLI failure---Self in Sleep_For"));

      Request := To_Timespec (Rel_Time + Clock + Clock_Delay_Correction);
      loop
         Result := cond_timedwait
           (Self_ID.LL.CV'Access, Self_ID.LL.L'Access, Request'Access);
         exit when Result /= EINTR;
      end loop;
      pragma Assert
        (Result = 0
          or else
            (Result = ETIME and then Clock >=
               To_Duration (Request) - Clock_Delay_Correction)
          or else Shutdown ("GNULLI failure---Sleep_For (early wakeup)"));
   end Sleep_For;

   -----------------
   -- Sleep_Until --
   -----------------

   procedure Sleep_Until (Self_ID : Task_ID; Abs_Time : Duration) is
      Result : Interfaces.C.int;
      Request : aliased timespec;

   begin
      pragma Assert (Self_ID = Self
        or else Shutdown ("GNULLI failure---Self in Sleep_Until"));

      Request := To_Timespec (Abs_Time + Clock_Delay_Correction);
      loop
         Result := cond_timedwait
           (Self_ID.LL.CV'Access, Self_ID.LL.L'Access, Request'Access);
         exit when Result /= EINTR;
      end loop;
      pragma Assert
        (Result = 0
          or else (Result = ETIME and then Clock >=
            To_Duration (Request) - Clock_Delay_Correction)
          or else Shutdown ("GNULLI failure---Sleep_Until (early wakeup)"));
   end Sleep_Until;

   ------------
   -- Wakeup --
   ------------

   procedure Wakeup (T : Task_ID) is
      Result : Interfaces.C.int;

   begin
      Result := cond_signal (T.LL.CV'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Wakeup"));
   end Wakeup;

   -----------
   -- Yield --
   -----------

   procedure Yield is
   begin
      System.OS_Interface.thr_yield;
   end Yield;

   ------------------
   -- Set_Priority --
   ------------------

   procedure Set_Priority (T : Task_ID; Prio : System.Any_Priority) is
      Prio_Param : struct_pcparms;
      Result     : Interfaces.C.int;
   begin
      T.LL.Current_Priority := Interfaces.C.int (Prio);
      if Is_Priority_Supported then
         Prio_Param.pc_cid := Class_Info.pc_cid;
         Prio_Param.rt_pri := pri_t (Prio);
         Prio_Param.rt_tqsecs := RT_TQINF;
         Prio_Param.rt_tqnsecs := 0;
         Result := Interfaces.C.int (
           priocntl (1, P_LWPID, T.LL.LWP, PC_SETPARMS, Prio_Param'Address));
         pragma Assert (Result /= -1 or else
           Shutdown ("GNULLI failure---Set_Priority" &
           Interfaces.C.int'Image (errno)));
      else
         --  This shouLdn't be needed if the thread priority has no meaning
         --  at all. However, under Solaris we need to set this for
         --  delay to expire correct ????
         Result := thr_setprio (T.LL.Thread, Interfaces.C.int (Prio));
         pragma Assert (Result = 0
           or else Shutdown ("GNULLI failure---Set_Priority"));
      end if;
   end Set_Priority;

   ------------------
   -- Get_Priority --
   ------------------

   function Get_Priority (T : Task_ID) return System.Any_Priority is
   begin
      return System.Any_Priority (T.LL.Current_Priority);
   end Get_Priority;

   ----------------
   -- Enter_Task --
   ----------------

   procedure Enter_Task (Self_ID : Task_ID) is
      Result  : Interfaces.C.int;
      Old_Set : aliased sigset_t;

   begin

      Self_ID.LL.Thread := thr_self;
      Self_ID.LL.LWP := lwp_self;

      --  It is not safe for the new task accept signals until it
      --  has bound its TCB pointer to the thread with thr_setspecific (),
      --  since the handler wrappers use the TCB pointer
      --  to restore the stack limit.

      --  Result := thr_setspecific (ATCB_Key, To_Address (Self_ID));
      --  pragma Assert (Result = 0
      --   or else Shutdown ("GNULLI failure---Enter_Task (thr_setspecific)"));
      --  We do not need above code if we do direct fetch of Task_ID in Self.
      --  %%%%%

      --  Must wait until the above operation is done to unmask signals,
      --  since signal handler for abort will try to access the ATCB to
      --  check whether abort is deferred, and exception propagation will
      --  try to use task-specific data as mentioned above.

      Result := thr_sigsetmask
        (SIG_UNBLOCK, Unblocked_Signal_Mask'Access, Old_Set'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Enter_Task (thr_sigsetmask)"));
   end Enter_Task;

   ----------------------
   --  Initialize_TCB  --
   ----------------------

   procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
      Result : Interfaces.C.int;

   begin

      Result := mutex_init
        (Self_ID.LL.L'Access, USYNC_THREAD, System.Null_Address);
      pragma Assert (Result = 0 or else Result = ENOMEM
        or else Shutdown ("GNULLI failure---mutex_init"));
      if Result = 0 then
         Result := cond_init (Self_ID.LL.CV'Access, USYNC_THREAD, 0);
         pragma Assert (Result = 0 or else Result = ENOMEM
           or else Shutdown ("GNULLI failure---cond_init"));
         if Result /= 0 then
            Result := mutex_destroy (Self_ID.LL.L'Access);
            pragma Assert (Result = 0
              or else Shutdown ("GNULLI failure---mutex_destory"));
            Succeeded := False;
         else
            Succeeded := True;
         end if;
      else
         Succeeded := False;
      end if;

   end Initialize_TCB;

   -----------------
   -- Create_Task --
   -----------------


   procedure Create_Task
     (T          : Task_ID;
      Wrapper    : System.Address;
      Stack_Size : System.Parameters.Size_Type;
      Priority   : System.Any_Priority;
      Succeeded  : out Boolean)
   is
      Result     : Interfaces.C.int;
      Old_Set    : aliased sigset_t;
      Activator  : Task_ID := Self;
      --  This could be passed as a parameter.
      --  However, this infomation is needed only for Solaris.
      --  We did not want to modiy the procedure specification in the
      --  spec of this package which is shared by all implementations.

      Old_Prio   : System.Any_Priority := Get_Priority (Activator);

      Adjusted_Stack_Size : Interfaces.C.size_t;

      function Thread_Body_Access is new
        Unchecked_Conversion (System.Address, Thread_Body);

   begin
      if Stack_Size = System.Parameters.Unspecified_Size then
         Adjusted_Stack_Size := Default_Stack_Size;
      else
         if Stack_Size < Size_Type (Minimum_Stack_Size) then
            Adjusted_Stack_Size :=
              Interfaces.C.size_t (Stack_Size) + Minimum_Stack_Size;

            --  sum, instead of max:  may be overkill, but should be safe
            --  thr_min_stack is a function call.

            --  Actually, we want to get the Default_Stack_Size and
            --  Minimum_Stack_Size from the file System.Parameters.
            --  Right now the package is not made target specific.
            --  We use our own local definitions for now ???

         else
            Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
         end if;

      end if;

      --  Since the initial signal mask of a thread is inherited from the
      --  creator, we need to set our local signal mask mask all signals
      --  during the creation operation, to make sure the new thread is
      --  not disturbed by signals before it has set its own Task_ID.

      Result := thr_sigsetmask
        (SIG_SETMASK, All_Signal_Mask'Access, Old_Set'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Create_Task (thr_sigsetmask)"));

      Set_Priority (Activator, Priority);
      --  Temporarily modify the caller's priority so that newly created
      --  thread (lwp) will inherit the priority.

      T.LL.Current_Priority := Interfaces.C.int (Priority);
      --  This particular field should be synchronized with the actual
      --  task priority through the call to Set_Priority if Priority is
      --  supported. However, we do not have the task activated yet hence
      --  setting it manually.

      Result := thr_create
        (System.Null_Address,
         Adjusted_Stack_Size,
         Thread_Body_Access (Wrapper),
         To_Address (T),
         THR_BOUND + THR_DETACHED,
         T.LL.Thread'Access);

      Set_Priority (Activator, Old_Prio);
      --  Change back to the original priority

      Succeeded := Result = 0;
      pragma Assert (Result = 0 or else Result = ENOMEM
        or else Result = EAGAIN
        or else Shutdown ("GNULLI failure---Create_Task (thr_create)"));

      Result := thr_sigsetmask
        (SIG_SETMASK, Old_Set'Unchecked_Access, null);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Create_Task (thr_sigsetmask)"));

   end Create_Task;

   ------------------
   -- Finalize_TCB --
   ------------------

   procedure Finalize_TCB (T : Task_ID) is
      Result : Interfaces.C.int;
      Tmp    : Task_ID := T;

   begin
      Result := mutex_destroy (T.LL.L'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Finalize_TCB (mutex_destroy)"));
      Result := cond_destroy (T.LL.CV'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Finalize_TCB (cond_destroy)"));
      --  Free (Tmp);
   end Finalize_TCB;

   ---------------
   -- Exit_Task --
   ---------------

   procedure Exit_Task is
   begin
      thr_exit (System.Null_Address);
   end Exit_Task;

   ----------------
   -- Abort_Task --
   ----------------

   procedure Abort_Task (T : Task_ID) is
      Result : Interfaces.C.int;

   begin
      Result := thr_kill (T.LL.Thread,
        Signal (System.Interrupt_Management.Abort_Task_Interrupt));
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Abort_Task"));
   end Abort_Task;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Environment_Task : Task_ID) is
      act       : aliased struct_sigaction;
      old_act   : aliased struct_sigaction;
      Tmp_Set   : aliased sigset_t;
      Result    : Interfaces.C.int;

   begin

      Environmental_Task_ID := Environment_Task;

      Enter_Task (Environment_Task);

      --  Install the abort-signal handler

      act.sa_flags := 16;
      --  Set sa_flags to SA_NODEFER so that during the handler execution
      --  we do not change the Signal_Mask to be masked for the Abort_Signal.
      --  This is a temporary fix to the problem that the Signal_Mask is
      --  not restored after the exception (longjmp) from the handler.
      --  The right fix should be made in sigsetjmp so that we save
      --  the Signal_Set and restore it after a longjmp.
      --  In that case, this field should be changed back to 0. ???

      act.sa_handler := Abort_Handler'Address;
      Result := sigemptyset (Tmp_Set'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Initialize (sigemptyset)"));
      act.sa_mask := Tmp_Set;

      Result :=
        sigaction (
          Signal (System.Interrupt_Management.Abort_Task_Interrupt),
          act'Access,
          old_act'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Initialize (sigaction)"));

      --  If multiple processor are available we may set the concurrency
      --  so that true parallel executions of threads are possible as follows:

      --  Result := thr_setconcurrency (sysconf (SC_NPROCESSORS_ONLN));
      --  pragma Assert (Result = 0
      --    or else Shutdown ("GNULLI failure---Initialize (sysconf)"));

      --  However, it seems better that we let the user decide what to do
      --  with available processors. Therefore, as a default, RTS does not
      --  set the concurrency level here. ???

   end Initialize;

begin
   declare
      Result : Interfaces.C.int;
   begin
      Result := sigfillset (All_Signal_Mask'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Initialize (sigfillset)"));

      Result := sigemptyset (Unblocked_Signal_Mask'Access);
      pragma Assert (Result = 0
        or else Shutdown ("GNULLI failure---Initialize (sigemptyset)"));

      for J in Interrupt_Management.Interrupt_ID loop
         if System.Interrupt_Management.Keep_Unmasked (J) then
            Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
            pragma Assert (Result = 0
              or else Shutdown ("GNULLI failure---Initialize (sigaddset)"));
         end if;
      end loop;

      --  Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
      --  pragma Assert (Result = 0
      --    or else Shutdown ("GNULLI failure---Initialize (thr_keycreate)"));
      --  We do not need above code if we do direct fetch of Task_ID in Self.
      --  %%%%%
   end;

   declare

      Prio_Param : struct_pcparms;
      Result : Interfaces.C.long;

   begin

      Class_Info.pc_clname (1) := 'R';
      Class_Info.pc_clname (2) := 'T';

      Result := priocntl (1, P_LWPID, lwp_self, PC_GETCID, Class_Info'Address);

      Prio_Param.pc_cid := Class_Info.pc_cid;
      Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
      Prio_Param.rt_tqsecs := RT_TQINF;

      Result :=
        priocntl (1, P_LWPID, lwp_self, PC_SETPARMS, Prio_Param'Address);

      --  Test if the Real-Time class is supported. If not we know that
      --  priorities can not be enforced.

      if Result /= -1 then
         Is_Priority_Supported := true;
      end if;

   end;

end System.Task_Primitives.Operations;
