|
111
|
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 -- --
|
|
131
|
9 -- Copyright (C) 1997-2018, Free Software Foundation, Inc. --
|
|
111
|
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
|
|
|
34 pragma Polling (Off);
|
|
|
35 -- Turn off polling, we do not want ATC polling to take place during tasking
|
|
|
36 -- operations. It causes infinite loops and other problems.
|
|
|
37
|
|
|
38 package body System.OS_Interface is
|
|
|
39
|
|
|
40 use Interfaces.C;
|
|
|
41
|
|
|
42 -----------------
|
|
|
43 -- To_Duration --
|
|
|
44 -----------------
|
|
|
45
|
|
|
46 function To_Duration (TS : timespec) return Duration is
|
|
|
47 begin
|
|
|
48 return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
|
|
|
49 end To_Duration;
|
|
|
50
|
|
|
51 ------------------------
|
|
|
52 -- To_Target_Priority --
|
|
|
53 ------------------------
|
|
|
54
|
|
|
55 function To_Target_Priority
|
|
|
56 (Prio : System.Any_Priority) return Interfaces.C.int
|
|
|
57 is
|
|
|
58 Dispatching_Policy : Character;
|
|
|
59 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
|
|
|
60
|
|
|
61 Time_Slice_Val : Integer;
|
|
|
62 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
|
|
|
63
|
|
|
64 begin
|
|
|
65 -- For the case SCHED_OTHER the only valid priority across all supported
|
|
|
66 -- versions of AIX is 1 (note that the scheduling policy can be set
|
|
|
67 -- with the pragma Task_Dispatching_Policy or setting the time slice
|
|
|
68 -- value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines
|
|
|
69 -- priorities in the range 1 .. 127. This means that we must map
|
|
|
70 -- System.Any_Priority in the range 0 .. 126 to 1 .. 127.
|
|
|
71
|
|
|
72 if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then
|
|
|
73 return 1;
|
|
|
74 else
|
|
|
75 return Interfaces.C.int (Prio) + 1;
|
|
|
76 end if;
|
|
|
77 end To_Target_Priority;
|
|
|
78
|
|
|
79 -----------------
|
|
|
80 -- To_Timespec --
|
|
|
81 -----------------
|
|
|
82
|
|
|
83 function To_Timespec (D : Duration) return timespec is
|
|
|
84 S : time_t;
|
|
|
85 F : Duration;
|
|
|
86
|
|
|
87 begin
|
|
|
88 S := time_t (Long_Long_Integer (D));
|
|
|
89 F := D - Duration (S);
|
|
|
90
|
|
|
91 -- If F is negative due to a round-up, adjust for positive F value
|
|
|
92
|
|
|
93 if F < 0.0 then
|
|
|
94 S := S - 1;
|
|
|
95 F := F + 1.0;
|
|
|
96 end if;
|
|
|
97
|
|
|
98 return timespec'(tv_sec => S,
|
|
|
99 tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
|
|
|
100 end To_Timespec;
|
|
|
101
|
|
|
102 -----------------
|
|
|
103 -- sched_yield --
|
|
|
104 -----------------
|
|
|
105
|
|
|
106 -- AIX Thread does not have sched_yield;
|
|
|
107
|
|
|
108 function sched_yield return int is
|
|
|
109 procedure pthread_yield;
|
|
|
110 pragma Import (C, pthread_yield, "sched_yield");
|
|
|
111 begin
|
|
|
112 pthread_yield;
|
|
|
113 return 0;
|
|
|
114 end sched_yield;
|
|
|
115
|
|
|
116 --------------------
|
|
|
117 -- Get_Stack_Base --
|
|
|
118 --------------------
|
|
|
119
|
|
|
120 function Get_Stack_Base (thread : pthread_t) return Address is
|
|
|
121 pragma Warnings (Off, thread);
|
|
|
122 begin
|
|
|
123 return Null_Address;
|
|
|
124 end Get_Stack_Base;
|
|
|
125
|
|
|
126 --------------------------
|
|
|
127 -- PTHREAD_PRIO_INHERIT --
|
|
|
128 --------------------------
|
|
|
129
|
|
|
130 AIX_Version : Integer := 0;
|
|
|
131 -- AIX version in the form xy for AIX version x.y (0 means not set)
|
|
|
132
|
|
|
133 SYS_NMLN : constant := 32;
|
|
|
134 -- AIX system constant used to define utsname, see sys/utsname.h
|
|
|
135
|
|
|
136 subtype String_NMLN is String (1 .. SYS_NMLN);
|
|
|
137
|
|
|
138 type utsname is record
|
|
|
139 sysname : String_NMLN;
|
|
|
140 nodename : String_NMLN;
|
|
|
141 release : String_NMLN;
|
|
|
142 version : String_NMLN;
|
|
|
143 machine : String_NMLN;
|
|
|
144 procserial : String_NMLN;
|
|
|
145 end record;
|
|
|
146 pragma Convention (C, utsname);
|
|
|
147
|
|
|
148 procedure uname (name : out utsname);
|
|
|
149 pragma Import (C, uname);
|
|
|
150
|
|
|
151 function PTHREAD_PRIO_INHERIT return int is
|
|
|
152 name : utsname;
|
|
|
153
|
|
|
154 function Val (C : Character) return Integer;
|
|
|
155 -- Transform a numeric character ('0' .. '9') to an integer
|
|
|
156
|
|
|
157 ---------
|
|
|
158 -- Val --
|
|
|
159 ---------
|
|
|
160
|
|
|
161 function Val (C : Character) return Integer is
|
|
|
162 begin
|
|
|
163 return Character'Pos (C) - Character'Pos ('0');
|
|
|
164 end Val;
|
|
|
165
|
|
|
166 -- Start of processing for PTHREAD_PRIO_INHERIT
|
|
|
167
|
|
|
168 begin
|
|
|
169 if AIX_Version = 0 then
|
|
|
170
|
|
|
171 -- Set AIX_Version
|
|
|
172
|
|
|
173 uname (name);
|
|
|
174 AIX_Version := Val (name.version (1)) * 10 + Val (name.release (1));
|
|
|
175 end if;
|
|
|
176
|
|
|
177 if AIX_Version < 53 then
|
|
|
178
|
|
|
179 -- Under AIX < 5.3, PTHREAD_PRIO_INHERIT is defined as 0 in pthread.h
|
|
|
180
|
|
|
181 return 0;
|
|
|
182
|
|
|
183 else
|
|
|
184 -- Under AIX >= 5.3, PTHREAD_PRIO_INHERIT is defined as 3
|
|
|
185
|
|
|
186 return 3;
|
|
|
187 end if;
|
|
|
188 end PTHREAD_PRIO_INHERIT;
|
|
|
189
|
|
|
190 end System.OS_Interface;
|
