Subversion Repositories scarts

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                     S Y S T E M . T A S K _ I N F O                      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
--                                                                          --
-- GNAT 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.  GNAT 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 GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, 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.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
--  This package body contains the routines associated with the implementation
--  of the Task_Info pragma.
 
--  This is the SGI specific version of this module.
 
with Interfaces.C;
with System.OS_Interface;
with System;
with Unchecked_Conversion;
 
package body System.Task_Info is
 
   use System.OS_Interface;
   use type Interfaces.C.int;
 
   function To_Resource_T is new
     Unchecked_Conversion (Resource_Vector_T, resource_t);
 
   MP_NPROCS : constant := 1;
 
   function Sysmp (Cmd : Integer) return Integer;
   pragma Import (C, Sysmp);
 
   function Num_Processors (Cmd : Integer := MP_NPROCS) return Integer
     renames Sysmp;
 
   function Geteuid return Integer;
   pragma Import (C, Geteuid);
 
   Locking_Map : constant array (Page_Locking) of Interfaces.C.int :=
     (NOLOCK   => 0,
      PROCLOCK => 1,
      TXTLOCK  => 2,
      DATLOCK  => 4);
 
   -------------------------------
   -- Resource_Vector_Functions --
   -------------------------------
 
   package body Resource_Vector_Functions is
 
      ---------
      -- "+" --
      ---------
 
      function "+" (R : Resource_T) return Resource_Vector_T is
         Result : Resource_Vector_T  := NO_RESOURCES;
      begin
         Result (Resource_T'Pos (R)) := True;
         return Result;
      end "+";
 
      function "+" (R1, R2 : Resource_T) return Resource_Vector_T is
         Result : Resource_Vector_T  := NO_RESOURCES;
      begin
         Result (Resource_T'Pos (R1)) := True;
         Result (Resource_T'Pos (R2)) := True;
         return Result;
      end "+";
 
      function "+"
        (R : Resource_T;
         S : Resource_Vector_T) return Resource_Vector_T
      is
         Result : Resource_Vector_T := S;
      begin
         Result (Resource_T'Pos (R)) := True;
         return Result;
      end "+";
 
      function "+"
        (S : Resource_Vector_T;
         R : Resource_T) return Resource_Vector_T
      is
         Result : Resource_Vector_T :=  S;
      begin
         Result (Resource_T'Pos (R)) := True;
         return Result;
      end "+";
 
      function "+" (S1, S2 : Resource_Vector_T) return Resource_Vector_T is
         Result : Resource_Vector_T;
      begin
         Result :=  S1 or S2;
         return Result;
      end "+";
 
      function "-"
        (S : Resource_Vector_T;
         R : Resource_T) return Resource_Vector_T
      is
         Result : Resource_Vector_T := S;
      begin
         Result (Resource_T'Pos (R)) := False;
         return Result;
      end "-";
 
   end Resource_Vector_Functions;
 
   ---------------
   -- New_Sproc --
   ---------------
 
   function New_Sproc (Attr : Sproc_Attributes) return sproc_t is
      Sproc_Attr : aliased sproc_attr_t;
      Sproc      : aliased sproc_t;
      Status     : int;
 
   begin
      Status := sproc_attr_init (Sproc_Attr'Unrestricted_Access);
 
      if Status = 0 then
         Status := sproc_attr_setresources
           (Sproc_Attr'Unrestricted_Access,
            To_Resource_T (Attr.Sproc_Resources));
 
         if Attr.CPU /= ANY_CPU then
            if Attr.CPU > Num_Processors then
               raise Invalid_CPU_Number;
            end if;
 
            Status := sproc_attr_setcpu
              (Sproc_Attr'Unrestricted_Access,
               int (Attr.CPU));
         end if;
 
         if Attr.Resident /= NOLOCK then
            if Geteuid /= 0 then
               raise Permission_Error;
            end if;
 
            Status := sproc_attr_setresident
              (Sproc_Attr'Unrestricted_Access,
                Locking_Map (Attr.Resident));
         end if;
 
         if Attr.NDPRI /= NDP_NONE then
 
--  ??? why is this commented out, should it be removed ?
--          if Geteuid /= 0 then
--             raise Permission_Error;
--          end if;
 
            Status :=
              sproc_attr_setprio
                (Sproc_Attr'Unrestricted_Access, int (Attr.NDPRI));
         end if;
 
         Status :=
           sproc_create
             (Sproc'Unrestricted_Access,
              Sproc_Attr'Unrestricted_Access,
              null,
              System.Null_Address);
 
         if Status /= 0 then
            Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
            raise Sproc_Create_Error;
         end if;
 
         Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
      end if;
 
      if Status /= 0 then
         raise Sproc_Create_Error;
      end if;
 
      return Sproc;
   end New_Sproc;
 
   ---------------
   -- New_Sproc --
   ---------------
 
   function New_Sproc
     (Sproc_Resources : Resource_Vector_T      := NO_RESOURCES;
      CPU             : CPU_Number             := ANY_CPU;
      Resident        : Page_Locking           := NOLOCK;
      NDPRI           : Non_Degrading_Priority := NDP_NONE) return sproc_t
   is
      Attr : constant Sproc_Attributes :=
               (Sproc_Resources, CPU, Resident, NDPRI);
   begin
      return New_Sproc (Attr);
   end New_Sproc;
 
   -------------------------------
   -- Unbound_Thread_Attributes --
   -------------------------------
 
   function Unbound_Thread_Attributes
     (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
      Thread_Timeslice : Duration          := 0.0) return Thread_Attributes
   is
   begin
      return (False, Thread_Resources, Thread_Timeslice);
   end Unbound_Thread_Attributes;
 
   -----------------------------
   -- Bound_Thread_Attributes --
   -----------------------------
 
   function Bound_Thread_Attributes
     (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
      Thread_Timeslice : Duration          := 0.0;
      Sproc            : sproc_t)
      return             Thread_Attributes
   is
   begin
      return (True, Thread_Resources, Thread_Timeslice, Sproc);
   end Bound_Thread_Attributes;
 
   -----------------------------
   -- Bound_Thread_Attributes --
   -----------------------------
 
   function Bound_Thread_Attributes
     (Thread_Resources : Resource_Vector_T      := NO_RESOURCES;
      Thread_Timeslice : Duration               := 0.0;
      Sproc_Resources  : Resource_Vector_T      := NO_RESOURCES;
      CPU              : CPU_Number             := ANY_CPU;
      Resident         : Page_Locking           := NOLOCK;
      NDPRI            : Non_Degrading_Priority := NDP_NONE)
      return Thread_Attributes
   is
      Sproc : constant sproc_t := New_Sproc
                (Sproc_Resources, CPU, Resident, NDPRI);
   begin
      return (True, Thread_Resources, Thread_Timeslice, Sproc);
   end Bound_Thread_Attributes;
 
   -----------------------------------
   -- New_Unbound_Thread_Attributes --
   -----------------------------------
 
   function New_Unbound_Thread_Attributes
     (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
      Thread_Timeslice : Duration          := 0.0) return Task_Info_Type
   is
   begin
      return new Thread_Attributes'
        (False, Thread_Resources, Thread_Timeslice);
   end New_Unbound_Thread_Attributes;
 
   ---------------------------------
   -- New_Bound_Thread_Attributes --
   ---------------------------------
 
   function New_Bound_Thread_Attributes
     (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
      Thread_Timeslice : Duration          := 0.0;
      Sproc            : sproc_t) return Task_Info_Type
   is
   begin
      return new Thread_Attributes'
        (True, Thread_Resources, Thread_Timeslice, Sproc);
   end  New_Bound_Thread_Attributes;
 
   ---------------------------------
   -- New_Bound_Thread_Attributes --
   ---------------------------------
 
   function New_Bound_Thread_Attributes
     (Thread_Resources : Resource_Vector_T      := NO_RESOURCES;
      Thread_Timeslice : Duration               := 0.0;
      Sproc_Resources  : Resource_Vector_T      := NO_RESOURCES;
      CPU              : CPU_Number             := ANY_CPU;
      Resident         : Page_Locking           := NOLOCK;
      NDPRI            : Non_Degrading_Priority := NDP_NONE)
      return Task_Info_Type
   is
      Sproc : constant sproc_t := New_Sproc
                (Sproc_Resources, CPU, Resident, NDPRI);
   begin
      return new Thread_Attributes'
        (True, Thread_Resources, Thread_Timeslice, Sproc);
   end  New_Bound_Thread_Attributes;
 
end System.Task_Info;