File : s-taprop-raven-cert-lynxos178.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- 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 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2013-2016, AdaCore --
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. GNARL 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 -- --
19 -- --
20 -- --
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 ------------------------------------------------------------------------------
28
29 -- This is the LynxOS-178 Ravenscar Cert version of this package
30
31 -- This package contains all the GNULL primitives that interface directly
32 -- with the underlying OS.
33
34 with Ada.Unchecked_Conversion;
35 with Interfaces.C;
36 with System.Init;
37 with System.OS_Interface;
38 with System.OS_Versions;
39 with System.Task_Info;
40 with System.Tasking.Debug;
41 with System.Float_Control;
42
43 package body System.Task_Primitives.Operations is
44
45 use System.Tasking;
46 use System.OS_Interface;
47 use System.OS_Versions;
48 use System.Parameters;
49 use type Interfaces.Unsigned_16;
50 use type Interfaces.C.int;
51
52 ----------------
53 -- Local Data --
54 ----------------
55
56 CLOCK_REALTIME : constant := 0;
57 -- This would usually be obtained from System.OS_Constants, but that
58 -- package is not used on cert platforms.
59
60 type Set_Stack_Limit_Proc_Acc is access procedure;
61 pragma Convention (C, Set_Stack_Limit_Proc_Acc);
62
63 Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
64 pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
65 -- Procedure to be called when a task is created to set stack limit if
66 -- limit checking is used.
67
68 --------------------
69 -- Local Packages --
70 --------------------
71
72 package Specific is
73
74 procedure Initialize;
75 pragma Inline (Initialize);
76 -- Initialize the thread specific data
77
78 procedure Set (Self_Id : Task_Id);
79 pragma Inline (Set);
80 -- Set the self id for the current task
81
82 function Self return Task_Id;
83 pragma Inline (Self);
84 -- Return a pointer to the Ada Task Control Block of the calling task
85
86 end Specific;
87
88 package body Specific is separate;
89 -- The body of this package is target specific
90
91 -----------
92 -- Sleep --
93 -----------
94
95 procedure Sleep
96 (Self_ID : Task_Id;
97 Reason : System.Tasking.Task_States)
98 is
99 pragma Unreferenced (Reason);
100
101 Result : Interfaces.C.int;
102
103 begin
104 Result :=
105 pthread_mutex_lock (mutex => Self_ID.Common.LL.L'Access);
106 pragma Assert (Result = 0);
107
108 -- If Wakeup was already called before Self_ID.Common.LL.L was locked,
109 -- we simply keep running (don't call pthread_cond_wait)
110
111 if not Self_ID.Common.Wakeup_Signaled then
112 Result :=
113 pthread_cond_wait
114 (cond => Self_ID.Common.LL.CV'Access,
115 mutex => (Self_ID.Common.LL.L'Access));
116
117 -- EINTR is not considered a failure
118
119 pragma Assert (Result = 0 or else Result = EINTR);
120 end if;
121
122 Self_ID.Common.Wakeup_Signaled := False;
123
124 Result :=
125 pthread_mutex_unlock (mutex => Self_ID.Common.LL.L'Access);
126 pragma Assert (Result = 0);
127 end Sleep;
128
129 -----------------
130 -- Delay_Until --
131 -----------------
132
133 procedure Delay_Until (Abs_Time : Time) is
134 pragma Assert (not Single_Lock);
135 pragma Assert (not Relative_Timed_Wait);
136
137 Self_ID : constant Task_Id := Specific.Self;
138 Request : aliased timespec := To_Timespec (Abs_Time);
139 Result : int;
140
141 begin
142 Result :=
143 pthread_mutex_lock (mutex => Self_ID.Common.LL.L'Access);
144 pragma Assert (Result = 0);
145
146 loop
147 Result :=
148 pthread_cond_timedwait
149 (cond => Self_ID.Common.LL.CV'Access,
150 mutex => Self_ID.Common.LL.L'Access,
151 abstime => Request'Access);
152
153 case Result is
154 when 0 =>
155
156 -- Spurious wakeup due to interrupt. Go around the loop and
157 -- wait again. The delay amount is absolute, so we don't need
158 -- to read the clock or do any time calculations. Note that the
159 -- mutex has already been reacquired in this case.
160
161 null;
162
163 when ETIMEDOUT =>
164
165 -- pthread_cond_timedwait timed out, which is what we want
166
167 exit;
168
169 when others =>
170
171 -- Should not be any other possibilities
172
173 pragma Assert (False);
174 end case;
175 end loop;
176
177 pragma Assert (Monotonic_Clock >= Abs_Time);
178
179 Result :=
180 pthread_mutex_unlock (mutex => Self_ID.Common.LL.L'Access);
181 pragma Assert (Result = 0);
182 end Delay_Until;
183
184 ---------------------
185 -- Monotonic_Clock --
186 ---------------------
187
188 function Monotonic_Clock return Duration is
189 TS : aliased timespec;
190 Result : Interfaces.C.int;
191
192 begin
193 -- Result := clock_gettime
194 -- (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
195 -- ??? Check value later
196
197 Result :=
198 clock_gettime (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
199 pragma Assert (Result = 0);
200 return To_Duration (TS);
201 end Monotonic_Clock;
202
203 -------------------
204 -- RT_Resolution --
205 -------------------
206
207 function RT_Resolution return Duration is
208 TS : aliased timespec;
209 Result : Interfaces.C.int;
210 begin
211 Result := clock_getres (CLOCK_REALTIME, TS'Unchecked_Access);
212 pragma Assert (Result = 0);
213 return To_Duration (TS);
214 end RT_Resolution;
215
216 ------------
217 -- Wakeup --
218 ------------
219
220 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
221 pragma Unreferenced (Reason);
222 Result : Interfaces.C.int;
223
224 begin
225 Result := pthread_mutex_lock (mutex => T.Common.LL.L'Access);
226 pragma Assert (Result = 0);
227
228 -- Wakeup_Signaled avoids a potential race condition, in case this is
229 -- called just before T calls Sleep.
230
231 pragma Assert (not T.Common.Wakeup_Signaled);
232 T.Common.Wakeup_Signaled := True;
233
234 Result := pthread_cond_signal (T.Common.LL.CV'Access);
235 pragma Assert (Result = 0);
236
237 Result := pthread_mutex_unlock (mutex => T.Common.LL.L'Access);
238 pragma Assert (Result = 0);
239 end Wakeup;
240
241 ------------------
242 -- Set_Priority --
243 ------------------
244
245 procedure Set_Priority
246 (T : Task_Id;
247 Prio : System.Any_Priority)
248 is
249 Result : Interfaces.C.int;
250 Param : aliased struct_sched_param;
251
252 begin
253 T.Common.Current_Priority := Prio;
254 Param.sched_priority := To_Target_Priority (Prio);
255 Result :=
256 pthread_setschedparam (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
257 pragma Assert (Result = 0);
258 end Set_Priority;
259
260 ------------------
261 -- Get_Priority --
262 ------------------
263
264 function Get_Priority (T : Task_Id) return System.Any_Priority is
265 begin
266 return T.Common.Current_Priority;
267 end Get_Priority;
268
269 ----------------
270 -- Enter_Task --
271 ----------------
272
273 procedure Enter_Task (Self_ID : Task_Id) is
274 begin
275 Self_ID.Common.LL.Thread := pthread_self;
276 Self_ID.Common.LL.LWP := lwp_self;
277
278 Specific.Set (Self_ID);
279
280 System.Float_Control.Reset;
281
282 System.Init.Install_Handler;
283
284 -- Register the task to System.Tasking.Debug
285
286 System.Tasking.Debug.Add_Task_Id (Self_ID);
287
288 -- If stack checking is enabled and limit checking is used, set the
289 -- stack limit for this task. The environment task has this initialized
290 -- by the binder-generated main when System.Stack_Check_Limits = True.
291
292 if Self_ID /= Operations.Environment_Task
293 and then Set_Stack_Limit_Hook /= null
294 then
295 Set_Stack_Limit_Hook.all;
296 end if;
297 end Enter_Task;
298
299 --------------------
300 -- Initialize_TCB --
301 --------------------
302
303 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
304 Mutex_Attr : aliased pthread_mutexattr_t;
305 Result : Interfaces.C.int;
306 Result0 : Interfaces.C.int;
307 Cond_Attr : aliased pthread_condattr_t;
308
309 begin
310 Result := pthread_mutexattr_init (Mutex_Attr'Access);
311 pragma Assert (Result = 0 or else Result = ENOMEM);
312
313 if Result = 0 then
314 Result :=
315 pthread_mutex_init
316 (Self_ID.Common.LL.L'Access,
317 Mutex_Attr'Access);
318 pragma Assert (Result = 0 or else Result = ENOMEM);
319
320 Result0 := pthread_mutexattr_destroy (Mutex_Attr'Access);
321 pragma Assert (Result0 = 0);
322 end if;
323
324 if Result /= 0 then
325 Succeeded := False;
326 return;
327 end if;
328
329 Result := pthread_condattr_init (Cond_Attr'Access);
330 pragma Assert (Result = 0 or else Result = ENOMEM);
331
332 if Result = 0 then
333
334 -- ??? Since we always use CLOCK_REALTIME, should be useless
335 -- Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
336 -- pragma Assert (Result = 0);
337
338 Result :=
339 pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
340 pragma Assert (Result = 0 or else Result = ENOMEM);
341 end if;
342
343 if Result = 0 then
344 Succeeded := True;
345 else
346 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
347 pragma Assert (Result = 0);
348 Succeeded := False;
349 end if;
350
351 Result := pthread_condattr_destroy (Cond_Attr'Access);
352 pragma Assert (Result = 0);
353 end Initialize_TCB;
354
355 -----------------
356 -- Create_Task --
357 -----------------
358
359 procedure Create_Task
360 (T : Task_Id;
361 Wrapper : System.Address;
362 Stack_Size : System.Parameters.Size_Type;
363 Priority : System.Any_Priority;
364 Base_CPU : System.Multiprocessors.CPU_Range;
365 Succeeded : out Boolean)
366 is
367 pragma Unreferenced (Base_CPU);
368 Attributes : aliased pthread_attr_t;
369 Adjusted_Stack_Size : Interfaces.C.size_t;
370 Page_Size : constant Interfaces.C.size_t :=
371 Interfaces.C.size_t (Get_Page_Size);
372 Result : Interfaces.C.int;
373
374 function Thread_Body_Access is new
375 Ada.Unchecked_Conversion (System.Address, Thread_Body);
376
377 use type Interfaces.C.size_t;
378 use System.Task_Info;
379
380 begin
381 -- Add ~1/4 to requested stack size for secondary stack
382
383 if Stack_Size = Unspecified_Size then
384 Adjusted_Stack_Size :=
385 System.OS_Interface.size_t ((Default_Stack_Size * 5) / 4);
386 elsif Stack_Size < Minimum_Stack_Size then
387 Adjusted_Stack_Size :=
388 System.OS_Interface.size_t ((Minimum_Stack_Size * 5) / 4);
389 else
390 Adjusted_Stack_Size :=
391 System.OS_Interface.size_t ((Stack_Size * 5) / 4);
392 end if;
393
394 if Stack_Base_Available then
395
396 -- If Stack Checking is supported then allocate 2 additional pages:
397
398 -- In the worst case, stack is allocated at something like
399 -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
400 -- to be sure the effective stack size is greater than what
401 -- has been asked.
402
403 Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size;
404 end if;
405
406 -- Round stack size as this is required by some OSes (Darwin)
407
408 Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1;
409 Adjusted_Stack_Size :=
410 Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size;
411
412 Result := pthread_attr_init (Attributes'Access);
413 pragma Assert (Result = 0 or else Result = ENOMEM);
414
415 if Result /= 0 then
416 Succeeded := False;
417 return;
418 end if;
419
420 Result :=
421 pthread_attr_setdetachstate
422 (Attributes'Access, PTHREAD_CREATE_DETACHED);
423 pragma Assert (Result = 0);
424
425 Result :=
426 pthread_attr_setstacksize (Attributes'Access, Adjusted_Stack_Size);
427 pragma Assert (Result = 0);
428
429 if T.Common.Task_Info /= Default_Scope then
430 case T.Common.Task_Info is
431 when System.Task_Info.Process_Scope =>
432 Result :=
433 pthread_attr_setscope
434 (Attributes'Access, PTHREAD_SCOPE_PROCESS);
435
436 when System.Task_Info.System_Scope =>
437 Result :=
438 pthread_attr_setscope
439 (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
440
441 when System.Task_Info.Default_Scope =>
442 Result := 0;
443 end case;
444
445 pragma Assert (Result = 0);
446 end if;
447
448 -- Since the initial signal mask of a thread is inherited from the
449 -- creator, and the Environment task has all its signals masked, we do
450 -- not need to manipulate caller's signal mask at this point. All tasks
451 -- in RTS will have All_Tasks_Mask initially.
452
453 -- Note: the use of Unrestricted_Access in the following call is needed
454 -- because otherwise we have an error of getting a access-to-volatile
455 -- value which points to a non-volatile object. But in this case it is
456 -- safe to do this, since we know we have no problems with aliasing and
457 -- Unrestricted_Access bypasses this check.
458
459 Result :=
460 pthread_create
461 (T.Common.LL.Thread'Unrestricted_Access,
462 Attributes'Access,
463 Thread_Body_Access (Wrapper),
464 To_Address (T));
465 pragma Assert (Result = 0 or else Result = EAGAIN);
466
467 Succeeded := Result = 0;
468
469 Result := pthread_attr_destroy (Attributes'Access);
470 pragma Assert (Result = 0);
471
472 if Succeeded then
473 Set_Priority (T, Priority);
474 end if;
475 end Create_Task;
476
477 ----------------
478 -- Initialize --
479 ----------------
480
481 procedure Initialize (Environment_Task : System.Tasking.Task_Id) is
482 begin
483 Specific.Initialize;
484
485 -- Store the identifier for the environment task
486
487 Operations.Environment_Task := Environment_Task;
488
489 Enter_Task (Environment_Task);
490 end Initialize;
491
492 ---------------------
493 -- Is_Task_Context --
494 ---------------------
495
496 function Is_Task_Context return Boolean is
497 begin
498 -- ??? TBI
499
500 return True;
501 end Is_Task_Context;
502
503 ----------
504 -- Self --
505 ----------
506
507 function Self return Task_Id renames Specific.Self;
508
509 end System.Task_Primitives.Operations;