1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4--                                                                          --
5--                   S Y S T E M . O S _ I N T E R F A C E                  --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--          Copyright (C) 1997-2020, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNARL is free software; you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNARL was developed by the GNARL team at Florida State University.       --
28-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
29--                                                                          --
30------------------------------------------------------------------------------
31
32--  This is a AIX (Native) version of this package
33
34package body System.OS_Interface is
35
36   use Interfaces.C;
37
38   -----------------
39   -- To_Duration --
40   -----------------
41
42   function To_Duration (TS : timespec) return Duration is
43   begin
44      return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
45   end To_Duration;
46
47   ------------------------
48   -- To_Target_Priority --
49   ------------------------
50
51   function To_Target_Priority
52     (Prio : System.Any_Priority) return Interfaces.C.int
53   is
54      Dispatching_Policy : Character;
55      pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
56
57      Time_Slice_Val : Integer;
58      pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
59
60   begin
61      --  For the case SCHED_OTHER the only valid priority across all supported
62      --  versions of AIX is 1 (note that the scheduling policy can be set
63      --  with the pragma Task_Dispatching_Policy or setting the time slice
64      --  value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines
65      --  priorities in the range 1 .. 127. This means that we must map
66      --  System.Any_Priority in the range 0 .. 126 to 1 .. 127.
67
68      if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then
69         return 1;
70      else
71         return Interfaces.C.int (Prio) + 1;
72      end if;
73   end To_Target_Priority;
74
75   -----------------
76   -- To_Timespec --
77   -----------------
78
79   function To_Timespec (D : Duration) return timespec is
80      S : time_t;
81      F : Duration;
82
83   begin
84      S := time_t (Long_Long_Integer (D));
85      F := D - Duration (S);
86
87      --  If F is negative due to a round-up, adjust for positive F value
88
89      if F < 0.0 then
90         S := S - 1;
91         F := F + 1.0;
92      end if;
93
94      return timespec'(tv_sec => S,
95                       tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
96   end To_Timespec;
97
98   -----------------
99   -- sched_yield --
100   -----------------
101
102   --  AIX Thread does not have sched_yield;
103
104   function sched_yield return int is
105      procedure pthread_yield;
106      pragma Import (C, pthread_yield, "sched_yield");
107   begin
108      pthread_yield;
109      return 0;
110   end sched_yield;
111
112   --------------------
113   -- Get_Stack_Base --
114   --------------------
115
116   function Get_Stack_Base (thread : pthread_t) return Address is
117      pragma Warnings (Off, thread);
118   begin
119      return Null_Address;
120   end Get_Stack_Base;
121
122   --------------------------
123   -- PTHREAD_PRIO_INHERIT --
124   --------------------------
125
126   AIX_Version : Integer := 0;
127   --  AIX version in the form xy for AIX version x.y (0 means not set)
128
129   SYS_NMLN : constant := 32;
130   --  AIX system constant used to define utsname, see sys/utsname.h
131
132   subtype String_NMLN is String (1 .. SYS_NMLN);
133
134   type utsname is record
135      sysname    : String_NMLN;
136      nodename   : String_NMLN;
137      release    : String_NMLN;
138      version    : String_NMLN;
139      machine    : String_NMLN;
140      procserial : String_NMLN;
141   end record;
142   pragma Convention (C, utsname);
143
144   procedure uname (name : out utsname);
145   pragma Import (C, uname);
146
147   function PTHREAD_PRIO_INHERIT return int is
148      name : utsname;
149
150      function Val (C : Character) return Integer;
151      --  Transform a numeric character ('0' .. '9') to an integer
152
153      ---------
154      -- Val --
155      ---------
156
157      function Val (C : Character) return Integer is
158      begin
159         return Character'Pos (C) - Character'Pos ('0');
160      end Val;
161
162   --  Start of processing for PTHREAD_PRIO_INHERIT
163
164   begin
165      if AIX_Version = 0 then
166
167         --  Set AIX_Version
168
169         uname (name);
170         AIX_Version := Val (name.version (1)) * 10 + Val (name.release (1));
171      end if;
172
173      if AIX_Version < 53 then
174
175         --  Under AIX < 5.3, PTHREAD_PRIO_INHERIT is defined as 0 in pthread.h
176
177         return 0;
178
179      else
180         --  Under AIX >= 5.3, PTHREAD_PRIO_INHERIT is defined as 3
181
182         return 3;
183      end if;
184   end PTHREAD_PRIO_INHERIT;
185
186end System.OS_Interface;
187