]>
Commit | Line | Data |
---|---|---|
84481f76 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
b497b460 | 3 | -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
84481f76 RK |
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 | -- -- | |
686d0984 | 9 | -- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- |
84481f76 RK |
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- -- | |
748086b7 JJ |
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- -- | |
84481f76 | 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
748086b7 JJ |
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/>. -- | |
84481f76 | 26 | -- -- |
91ed4b19 NN |
27 | -- GNARL was developed by the GNARL team at Florida State University. -- |
28 | -- Extensive contributions were provided by Ada Core Technologies, Inc. -- | |
84481f76 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
dc97c7a8 | 32 | -- This is a Tru64 version of this package |
84481f76 | 33 | |
dc97c7a8 AC |
34 | -- This package contains all the GNULL primitives that interface directly with |
35 | -- the underlying OS. | |
84481f76 RK |
36 | |
37 | pragma Polling (Off); | |
dc97c7a8 AC |
38 | -- Turn off polling, we do not want ATC polling to take place during tasking |
39 | -- operations. It causes infinite loops and other problems. | |
84481f76 | 40 | |
dc97c7a8 AC |
41 | with Interfaces; |
42 | with Interfaces.C; | |
3b91d88e | 43 | |
dc97c7a8 AC |
44 | with System.Tasking.Debug; |
45 | with System.Interrupt_Management; | |
ef992452 | 46 | with System.OS_Constants; |
3b91d88e | 47 | with System.OS_Primitives; |
84481f76 | 48 | with System.Task_Info; |
84481f76 | 49 | |
72774950 | 50 | with System.Soft_Links; |
72774950 JR |
51 | -- We use System.Soft_Links instead of System.Tasking.Initialization |
52 | -- because the later is a higher level package that we shouldn't depend on. | |
53 | -- For example when using the restricted run time, it is replaced by | |
54 | -- System.Tasking.Restricted.Stages. | |
55 | ||
84481f76 RK |
56 | package body System.Task_Primitives.Operations is |
57 | ||
ef992452 | 58 | package OSC renames System.OS_Constants; |
72774950 JR |
59 | package SSL renames System.Soft_Links; |
60 | ||
84481f76 RK |
61 | use System.Tasking.Debug; |
62 | use System.Tasking; | |
63 | use Interfaces.C; | |
64 | use System.OS_Interface; | |
65 | use System.Parameters; | |
66 | use System.OS_Primitives; | |
67 | ||
07fc65c4 GB |
68 | ---------------- |
69 | -- Local Data -- | |
70 | ---------------- | |
84481f76 RK |
71 | |
72 | -- The followings are logically constants, but need to be initialized | |
73 | -- at run time. | |
74 | ||
07fc65c4 GB |
75 | Single_RTS_Lock : aliased RTS_Lock; |
76 | -- This is a lock to allow only one thread of control in the RTS at | |
77 | -- a time; it is used to execute in mutual exclusion from all other tasks. | |
78 | -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List | |
84481f76 | 79 | |
b5e792e2 | 80 | Environment_Task_Id : Task_Id; |
09c239f6 | 81 | -- A variable to hold Task_Id for the environment task |
84481f76 RK |
82 | |
83 | Unblocked_Signal_Mask : aliased sigset_t; | |
84 | -- The set of signals that should unblocked in all tasks | |
85 | ||
86 | Time_Slice_Val : Integer; | |
87 | pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); | |
88 | ||
89 | Locking_Policy : Character; | |
90 | pragma Import (C, Locking_Policy, "__gl_locking_policy"); | |
91 | ||
92 | Dispatching_Policy : Character; | |
93 | pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); | |
94 | ||
84481f76 RK |
95 | Curpid : pid_t; |
96 | ||
fbf5a39b | 97 | Foreign_Task_Elaborated : aliased Boolean := True; |
09c239f6 | 98 | -- Used to identified fake tasks (i.e., non-Ada Threads) |
84481f76 | 99 | |
658cea5b AC |
100 | Abort_Handler_Installed : Boolean := False; |
101 | -- True if a handler for the abort signal is installed | |
102 | ||
84481f76 RK |
103 | -------------------- |
104 | -- Local Packages -- | |
105 | -------------------- | |
106 | ||
107 | package Specific is | |
108 | ||
b5e792e2 | 109 | procedure Initialize (Environment_Task : Task_Id); |
84481f76 | 110 | pragma Inline (Initialize); |
09c239f6 | 111 | -- Initialize various data needed by this package |
84481f76 | 112 | |
fbf5a39b AC |
113 | function Is_Valid_Task return Boolean; |
114 | pragma Inline (Is_Valid_Task); | |
115 | -- Does executing thread have a TCB? | |
116 | ||
b5e792e2 | 117 | procedure Set (Self_Id : Task_Id); |
84481f76 | 118 | pragma Inline (Set); |
09c239f6 | 119 | -- Set the self id for the current task |
84481f76 | 120 | |
b5e792e2 | 121 | function Self return Task_Id; |
84481f76 | 122 | pragma Inline (Self); |
09c239f6 | 123 | -- Return a pointer to the Ada Task Control Block of the calling task |
84481f76 RK |
124 | |
125 | end Specific; | |
126 | ||
127 | package body Specific is separate; | |
09c239f6 | 128 | -- The body of this package is target specific |
84481f76 | 129 | |
f4f92d9d AC |
130 | ---------------------------------- |
131 | -- ATCB allocation/deallocation -- | |
132 | ---------------------------------- | |
133 | ||
134 | package body ATCB_Allocation is separate; | |
135 | -- The body of this package is shared across several targets | |
136 | ||
fbf5a39b AC |
137 | --------------------------------- |
138 | -- Support for foreign threads -- | |
139 | --------------------------------- | |
140 | ||
b5e792e2 | 141 | function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; |
09c239f6 | 142 | -- Allocate and initialize a new ATCB for the current Thread |
fbf5a39b AC |
143 | |
144 | function Register_Foreign_Thread | |
b5e792e2 | 145 | (Thread : Thread_Id) return Task_Id is separate; |
fbf5a39b AC |
146 | |
147 | ----------------------- | |
148 | -- Local Subprograms -- | |
149 | ----------------------- | |
150 | ||
151 | procedure Abort_Handler (Sig : Signal); | |
09c239f6 | 152 | -- Signal handler used to implement asynchronous abort |
fbf5a39b | 153 | |
ec946d18 AC |
154 | function Get_Policy (Prio : System.Any_Priority) return Character; |
155 | pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); | |
156 | -- Get priority specific dispatching policy | |
157 | ||
84481f76 RK |
158 | ------------------- |
159 | -- Abort_Handler -- | |
160 | ------------------- | |
161 | ||
162 | procedure Abort_Handler (Sig : Signal) is | |
fbf5a39b AC |
163 | pragma Unreferenced (Sig); |
164 | ||
b5e792e2 | 165 | T : constant Task_Id := Self; |
84481f76 RK |
166 | Old_Set : aliased sigset_t; |
167 | ||
f3bc3723 EB |
168 | Result : Interfaces.C.int; |
169 | pragma Warnings (Off, Result); | |
170 | ||
84481f76 | 171 | begin |
658cea5b AC |
172 | -- It's not safe to raise an exception when using GCC ZCX mechanism. |
173 | -- Note that we still need to install a signal handler, since in some | |
174 | -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we | |
175 | -- need to send the Abort signal to a task. | |
fbf5a39b | 176 | |
164e06c6 | 177 | if ZCX_By_Default then |
fbf5a39b AC |
178 | return; |
179 | end if; | |
180 | ||
84481f76 | 181 | if T.Deferral_Level = 0 |
dae22b53 AC |
182 | and then T.Pending_ATC_Level < T.ATC_Nesting_Level |
183 | and then not T.Aborting | |
84481f76 RK |
184 | then |
185 | T.Aborting := True; | |
186 | ||
187 | -- Make sure signals used for RTS internal purpose are unmasked | |
188 | ||
dae22b53 AC |
189 | Result := |
190 | pthread_sigmask | |
191 | (SIG_UNBLOCK, | |
bb1f5840 ST |
192 | Unblocked_Signal_Mask'Access, |
193 | Old_Set'Access); | |
84481f76 RK |
194 | pragma Assert (Result = 0); |
195 | ||
196 | raise Standard'Abort_Signal; | |
197 | end if; | |
198 | end Abort_Handler; | |
199 | ||
200 | ------------------ | |
201 | -- Stack_Guard -- | |
202 | ------------------ | |
203 | ||
dae22b53 AC |
204 | -- The underlying thread system sets a guard page at the bottom of a thread |
205 | -- stack, so nothing is needed. | |
84481f76 | 206 | |
b5e792e2 | 207 | procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is |
fbf5a39b AC |
208 | pragma Unreferenced (T); |
209 | pragma Unreferenced (On); | |
84481f76 RK |
210 | begin |
211 | null; | |
212 | end Stack_Guard; | |
213 | ||
214 | -------------------- | |
215 | -- Get_Thread_Id -- | |
216 | -------------------- | |
217 | ||
b5e792e2 | 218 | function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is |
84481f76 RK |
219 | begin |
220 | return T.Common.LL.Thread; | |
221 | end Get_Thread_Id; | |
222 | ||
223 | ---------- | |
224 | -- Self -- | |
225 | ---------- | |
226 | ||
b5e792e2 | 227 | function Self return Task_Id renames Specific.Self; |
84481f76 RK |
228 | |
229 | --------------------- | |
230 | -- Initialize_Lock -- | |
231 | --------------------- | |
232 | ||
dae22b53 AC |
233 | -- Note: mutexes and cond_variables needed per-task basis are initialized |
234 | -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such | |
235 | -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any | |
12a13f01 | 236 | -- status change of RTS. Therefore raising Storage_Error in the following |
dae22b53 | 237 | -- routines should be able to be handled safely. |
84481f76 RK |
238 | |
239 | procedure Initialize_Lock | |
240 | (Prio : System.Any_Priority; | |
d90e94c7 | 241 | L : not null access Lock) |
84481f76 RK |
242 | is |
243 | Attributes : aliased pthread_mutexattr_t; | |
244 | Result : Interfaces.C.int; | |
245 | ||
246 | begin | |
247 | Result := pthread_mutexattr_init (Attributes'Access); | |
248 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
249 | ||
250 | if Result = ENOMEM then | |
251 | raise Storage_Error; | |
252 | end if; | |
253 | ||
254 | if Locking_Policy = 'C' then | |
255 | L.Ceiling := Interfaces.C.int (Prio); | |
256 | end if; | |
257 | ||
258 | Result := pthread_mutex_init (L.L'Access, Attributes'Access); | |
259 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
260 | ||
261 | if Result = ENOMEM then | |
262 | Result := pthread_mutexattr_destroy (Attributes'Access); | |
263 | raise Storage_Error; | |
264 | end if; | |
265 | ||
266 | Result := pthread_mutexattr_destroy (Attributes'Access); | |
267 | pragma Assert (Result = 0); | |
268 | end Initialize_Lock; | |
269 | ||
d90e94c7 | 270 | procedure Initialize_Lock |
dae22b53 AC |
271 | (L : not null access RTS_Lock; |
272 | Level : Lock_Level) | |
d90e94c7 | 273 | is |
fbf5a39b AC |
274 | pragma Unreferenced (Level); |
275 | ||
84481f76 RK |
276 | Attributes : aliased pthread_mutexattr_t; |
277 | Result : Interfaces.C.int; | |
278 | ||
279 | begin | |
280 | Result := pthread_mutexattr_init (Attributes'Access); | |
281 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
282 | ||
283 | if Result = ENOMEM then | |
284 | raise Storage_Error; | |
285 | end if; | |
286 | ||
287 | Result := pthread_mutex_init (L, Attributes'Access); | |
288 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
289 | ||
290 | if Result = ENOMEM then | |
291 | Result := pthread_mutexattr_destroy (Attributes'Access); | |
292 | raise Storage_Error; | |
293 | end if; | |
294 | ||
295 | Result := pthread_mutexattr_destroy (Attributes'Access); | |
296 | pragma Assert (Result = 0); | |
297 | end Initialize_Lock; | |
298 | ||
299 | ------------------- | |
300 | -- Finalize_Lock -- | |
301 | ------------------- | |
302 | ||
d90e94c7 | 303 | procedure Finalize_Lock (L : not null access Lock) is |
84481f76 RK |
304 | Result : Interfaces.C.int; |
305 | begin | |
306 | Result := pthread_mutex_destroy (L.L'Access); | |
307 | pragma Assert (Result = 0); | |
308 | end Finalize_Lock; | |
309 | ||
d90e94c7 | 310 | procedure Finalize_Lock (L : not null access RTS_Lock) is |
84481f76 RK |
311 | Result : Interfaces.C.int; |
312 | begin | |
313 | Result := pthread_mutex_destroy (L); | |
314 | pragma Assert (Result = 0); | |
315 | end Finalize_Lock; | |
316 | ||
317 | ---------------- | |
318 | -- Write_Lock -- | |
319 | ---------------- | |
320 | ||
d90e94c7 | 321 | procedure Write_Lock |
dae22b53 AC |
322 | (L : not null access Lock; |
323 | Ceiling_Violation : out Boolean) | |
d90e94c7 | 324 | is |
84481f76 | 325 | Result : Interfaces.C.int; |
b5e792e2 AC |
326 | Self_ID : Task_Id; |
327 | All_Tasks_Link : Task_Id; | |
84481f76 RK |
328 | Current_Prio : System.Any_Priority; |
329 | ||
330 | begin | |
09c239f6 | 331 | -- Perform ceiling checks only when this is the locking policy in use |
84481f76 RK |
332 | |
333 | if Locking_Policy = 'C' then | |
334 | Self_ID := Self; | |
335 | All_Tasks_Link := Self_ID.Common.All_Tasks_Link; | |
336 | Current_Prio := Get_Priority (Self_ID); | |
337 | ||
07fc65c4 GB |
338 | -- If there is no other task, no need to check priorities |
339 | ||
340 | if All_Tasks_Link /= Null_Task | |
341 | and then L.Ceiling < Interfaces.C.int (Current_Prio) | |
342 | then | |
84481f76 RK |
343 | Ceiling_Violation := True; |
344 | return; | |
345 | end if; | |
346 | end if; | |
347 | ||
348 | Result := pthread_mutex_lock (L.L'Access); | |
84481f76 RK |
349 | pragma Assert (Result = 0); |
350 | ||
351 | Ceiling_Violation := False; | |
352 | end Write_Lock; | |
353 | ||
07fc65c4 | 354 | procedure Write_Lock |
dae22b53 AC |
355 | (L : not null access RTS_Lock; |
356 | Global_Lock : Boolean := False) | |
07fc65c4 | 357 | is |
84481f76 RK |
358 | Result : Interfaces.C.int; |
359 | begin | |
07fc65c4 GB |
360 | if not Single_Lock or else Global_Lock then |
361 | Result := pthread_mutex_lock (L); | |
362 | pragma Assert (Result = 0); | |
363 | end if; | |
84481f76 RK |
364 | end Write_Lock; |
365 | ||
b5e792e2 | 366 | procedure Write_Lock (T : Task_Id) is |
84481f76 RK |
367 | Result : Interfaces.C.int; |
368 | begin | |
07fc65c4 GB |
369 | if not Single_Lock then |
370 | Result := pthread_mutex_lock (T.Common.LL.L'Access); | |
371 | pragma Assert (Result = 0); | |
372 | end if; | |
84481f76 RK |
373 | end Write_Lock; |
374 | ||
375 | --------------- | |
376 | -- Read_Lock -- | |
377 | --------------- | |
378 | ||
d90e94c7 | 379 | procedure Read_Lock |
64a63cd5 | 380 | (L : not null access Lock; |
dae22b53 AC |
381 | Ceiling_Violation : out Boolean) |
382 | is | |
84481f76 RK |
383 | begin |
384 | Write_Lock (L, Ceiling_Violation); | |
385 | end Read_Lock; | |
386 | ||
387 | ------------ | |
388 | -- Unlock -- | |
389 | ------------ | |
390 | ||
d90e94c7 | 391 | procedure Unlock (L : not null access Lock) is |
84481f76 RK |
392 | Result : Interfaces.C.int; |
393 | begin | |
394 | Result := pthread_mutex_unlock (L.L'Access); | |
395 | pragma Assert (Result = 0); | |
396 | end Unlock; | |
397 | ||
d90e94c7 | 398 | procedure Unlock |
dae22b53 AC |
399 | (L : not null access RTS_Lock; |
400 | Global_Lock : Boolean := False) | |
d90e94c7 | 401 | is |
84481f76 RK |
402 | Result : Interfaces.C.int; |
403 | begin | |
07fc65c4 GB |
404 | if not Single_Lock or else Global_Lock then |
405 | Result := pthread_mutex_unlock (L); | |
406 | pragma Assert (Result = 0); | |
407 | end if; | |
84481f76 RK |
408 | end Unlock; |
409 | ||
b5e792e2 | 410 | procedure Unlock (T : Task_Id) is |
84481f76 RK |
411 | Result : Interfaces.C.int; |
412 | begin | |
07fc65c4 GB |
413 | if not Single_Lock then |
414 | Result := pthread_mutex_unlock (T.Common.LL.L'Access); | |
415 | pragma Assert (Result = 0); | |
416 | end if; | |
84481f76 RK |
417 | end Unlock; |
418 | ||
dae22b53 AC |
419 | ----------------- |
420 | -- Set_Ceiling -- | |
421 | ----------------- | |
422 | ||
423 | -- Dynamic priority ceilings are not supported by the underlying system | |
424 | ||
425 | procedure Set_Ceiling | |
426 | (L : not null access Lock; | |
427 | Prio : System.Any_Priority) | |
428 | is | |
429 | pragma Unreferenced (L, Prio); | |
430 | begin | |
431 | null; | |
432 | end Set_Ceiling; | |
433 | ||
84481f76 RK |
434 | ----------- |
435 | -- Sleep -- | |
436 | ----------- | |
437 | ||
438 | procedure Sleep | |
b5e792e2 | 439 | (Self_ID : Task_Id; |
84481f76 RK |
440 | Reason : System.Tasking.Task_States) |
441 | is | |
fbf5a39b AC |
442 | pragma Unreferenced (Reason); |
443 | ||
84481f76 | 444 | Result : Interfaces.C.int; |
fbf5a39b | 445 | |
84481f76 | 446 | begin |
196b1993 AC |
447 | Result := |
448 | pthread_cond_wait | |
449 | (cond => Self_ID.Common.LL.CV'Access, | |
450 | mutex => (if Single_Lock | |
451 | then Single_RTS_Lock'Access | |
452 | else Self_ID.Common.LL.L'Access)); | |
84481f76 | 453 | |
09c239f6 | 454 | -- EINTR is not considered a failure |
84481f76 RK |
455 | |
456 | pragma Assert (Result = 0 or else Result = EINTR); | |
457 | end Sleep; | |
458 | ||
459 | ----------------- | |
460 | -- Timed_Sleep -- | |
461 | ----------------- | |
462 | ||
dae22b53 AC |
463 | -- This is for use within the run-time system, so abort is assumed to be |
464 | -- already deferred, and the caller should be holding its own ATCB lock. | |
84481f76 RK |
465 | |
466 | procedure Timed_Sleep | |
b5e792e2 | 467 | (Self_ID : Task_Id; |
84481f76 RK |
468 | Time : Duration; |
469 | Mode : ST.Delay_Modes; | |
470 | Reason : System.Tasking.Task_States; | |
471 | Timedout : out Boolean; | |
472 | Yielded : out Boolean) | |
473 | is | |
fbf5a39b AC |
474 | pragma Unreferenced (Reason); |
475 | ||
dae22b53 AC |
476 | Base_Time : constant Duration := Monotonic_Clock; |
477 | Check_Time : Duration := Base_Time; | |
84481f76 RK |
478 | Abs_Time : Duration; |
479 | Request : aliased timespec; | |
480 | Result : Interfaces.C.int; | |
481 | ||
482 | begin | |
483 | Timedout := True; | |
484 | Yielded := False; | |
485 | ||
196b1993 AC |
486 | Abs_Time := |
487 | (if Mode = Relative | |
488 | then Duration'Min (Time, Max_Sensible_Delay) + Check_Time | |
489 | else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); | |
84481f76 RK |
490 | |
491 | if Abs_Time > Check_Time then | |
492 | Request := To_Timespec (Abs_Time); | |
493 | ||
494 | loop | |
dae22b53 | 495 | exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; |
84481f76 | 496 | |
196b1993 AC |
497 | Result := |
498 | pthread_cond_timedwait | |
499 | (cond => Self_ID.Common.LL.CV'Access, | |
500 | mutex => (if Single_Lock | |
501 | then Single_RTS_Lock'Access | |
502 | else Self_ID.Common.LL.L'Access), | |
503 | abstime => Request'Access); | |
84481f76 | 504 | |
dae22b53 AC |
505 | Check_Time := Monotonic_Clock; |
506 | exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; | |
84481f76 RK |
507 | |
508 | if Result = 0 or Result = EINTR then | |
fbf5a39b AC |
509 | |
510 | -- Somebody may have called Wakeup for us | |
511 | ||
84481f76 RK |
512 | Timedout := False; |
513 | exit; | |
514 | end if; | |
515 | ||
516 | pragma Assert (Result = ETIMEDOUT); | |
517 | end loop; | |
518 | end if; | |
519 | end Timed_Sleep; | |
520 | ||
521 | ----------------- | |
522 | -- Timed_Delay -- | |
523 | ----------------- | |
524 | ||
dae22b53 AC |
525 | -- This is for use in implementing delay statements, so we assume the |
526 | -- caller is abort-deferred but is holding no locks. | |
84481f76 RK |
527 | |
528 | procedure Timed_Delay | |
b5e792e2 | 529 | (Self_ID : Task_Id; |
84481f76 RK |
530 | Time : Duration; |
531 | Mode : ST.Delay_Modes) | |
532 | is | |
dae22b53 AC |
533 | Base_Time : constant Duration := Monotonic_Clock; |
534 | Check_Time : Duration := Base_Time; | |
84481f76 RK |
535 | Abs_Time : Duration; |
536 | Request : aliased timespec; | |
537 | Result : Interfaces.C.int; | |
538 | ||
539 | begin | |
07fc65c4 GB |
540 | if Single_Lock then |
541 | Lock_RTS; | |
542 | end if; | |
543 | ||
84481f76 RK |
544 | Write_Lock (Self_ID); |
545 | ||
196b1993 AC |
546 | Abs_Time := |
547 | (if Mode = Relative | |
548 | then Time + Check_Time | |
549 | else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); | |
84481f76 RK |
550 | |
551 | if Abs_Time > Check_Time then | |
552 | Request := To_Timespec (Abs_Time); | |
553 | Self_ID.Common.State := Delay_Sleep; | |
554 | ||
555 | loop | |
84481f76 RK |
556 | exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; |
557 | ||
196b1993 AC |
558 | Result := |
559 | pthread_cond_timedwait | |
560 | (cond => Self_ID.Common.LL.CV'Access, | |
561 | mutex => (if Single_Lock | |
562 | then Single_RTS_Lock'Access | |
563 | else Self_ID.Common.LL.L'Access), | |
564 | abstime => Request'Access); | |
84481f76 | 565 | |
dae22b53 AC |
566 | Check_Time := Monotonic_Clock; |
567 | exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; | |
84481f76 | 568 | |
dae22b53 AC |
569 | pragma Assert (Result = 0 or else |
570 | Result = ETIMEDOUT or else | |
571 | Result = EINTR); | |
84481f76 RK |
572 | end loop; |
573 | ||
574 | Self_ID.Common.State := Runnable; | |
575 | end if; | |
576 | ||
577 | Unlock (Self_ID); | |
07fc65c4 GB |
578 | |
579 | if Single_Lock then | |
580 | Unlock_RTS; | |
581 | end if; | |
582 | ||
84481f76 | 583 | Yield; |
84481f76 RK |
584 | end Timed_Delay; |
585 | ||
586 | --------------------- | |
587 | -- Monotonic_Clock -- | |
588 | --------------------- | |
589 | ||
590 | function Monotonic_Clock return Duration is | |
591 | TS : aliased timespec; | |
592 | Result : Interfaces.C.int; | |
84481f76 | 593 | begin |
c269a1f5 | 594 | Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); |
84481f76 RK |
595 | pragma Assert (Result = 0); |
596 | return To_Duration (TS); | |
597 | end Monotonic_Clock; | |
598 | ||
599 | ------------------- | |
600 | -- RT_Resolution -- | |
601 | ------------------- | |
602 | ||
603 | function RT_Resolution return Duration is | |
604 | begin | |
bc5f3720 RD |
605 | -- Returned value must be an integral multiple of Duration'Small (1 ns) |
606 | -- The following is the best approximation of 1/1024. The clock on the | |
607 | -- DEC Alpha ticks at 1024 Hz. | |
608 | ||
609 | return 0.000_976_563; | |
84481f76 RK |
610 | end RT_Resolution; |
611 | ||
612 | ------------ | |
613 | -- Wakeup -- | |
614 | ------------ | |
615 | ||
b5e792e2 | 616 | procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is |
fbf5a39b | 617 | pragma Unreferenced (Reason); |
84481f76 RK |
618 | Result : Interfaces.C.int; |
619 | begin | |
620 | Result := pthread_cond_signal (T.Common.LL.CV'Access); | |
621 | pragma Assert (Result = 0); | |
622 | end Wakeup; | |
623 | ||
624 | ----------- | |
625 | -- Yield -- | |
626 | ----------- | |
627 | ||
628 | procedure Yield (Do_Yield : Boolean := True) is | |
629 | Result : Interfaces.C.int; | |
91b1417d | 630 | pragma Unreferenced (Result); |
84481f76 RK |
631 | begin |
632 | if Do_Yield then | |
633 | Result := sched_yield; | |
634 | end if; | |
635 | end Yield; | |
636 | ||
637 | ------------------ | |
638 | -- Set_Priority -- | |
639 | ------------------ | |
640 | ||
641 | procedure Set_Priority | |
b5e792e2 | 642 | (T : Task_Id; |
fbf5a39b | 643 | Prio : System.Any_Priority; |
84481f76 RK |
644 | Loss_Of_Inheritance : Boolean := False) |
645 | is | |
fbf5a39b AC |
646 | pragma Unreferenced (Loss_Of_Inheritance); |
647 | ||
84481f76 RK |
648 | Result : Interfaces.C.int; |
649 | Param : aliased struct_sched_param; | |
650 | ||
ec946d18 AC |
651 | Priority_Specific_Policy : constant Character := Get_Policy (Prio); |
652 | -- Upper case first character of the policy name corresponding to the | |
653 | -- task as set by a Priority_Specific_Dispatching pragma. | |
654 | ||
84481f76 RK |
655 | begin |
656 | T.Common.Current_Priority := Prio; | |
657 | Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); | |
658 | ||
ec946d18 AC |
659 | if Dispatching_Policy = 'R' |
660 | or else Priority_Specific_Policy = 'R' | |
661 | or else Time_Slice_Val > 0 | |
662 | then | |
dae22b53 AC |
663 | Result := |
664 | pthread_setschedparam | |
665 | (T.Common.LL.Thread, SCHED_RR, Param'Access); | |
84481f76 | 666 | |
ec946d18 AC |
667 | elsif Dispatching_Policy = 'F' |
668 | or else Priority_Specific_Policy = 'F' | |
669 | or else Time_Slice_Val = 0 | |
670 | then | |
dae22b53 AC |
671 | Result := |
672 | pthread_setschedparam | |
673 | (T.Common.LL.Thread, SCHED_FIFO, Param'Access); | |
84481f76 RK |
674 | |
675 | else | |
dae22b53 AC |
676 | Result := |
677 | pthread_setschedparam | |
678 | (T.Common.LL.Thread, SCHED_OTHER, Param'Access); | |
84481f76 RK |
679 | end if; |
680 | ||
681 | pragma Assert (Result = 0); | |
682 | end Set_Priority; | |
683 | ||
684 | ------------------ | |
685 | -- Get_Priority -- | |
686 | ------------------ | |
687 | ||
b5e792e2 | 688 | function Get_Priority (T : Task_Id) return System.Any_Priority is |
84481f76 RK |
689 | begin |
690 | return T.Common.Current_Priority; | |
691 | end Get_Priority; | |
692 | ||
693 | ---------------- | |
694 | -- Enter_Task -- | |
695 | ---------------- | |
696 | ||
b5e792e2 | 697 | procedure Enter_Task (Self_ID : Task_Id) is |
84481f76 | 698 | begin |
f3bc3723 | 699 | Hide_Unhide_Yellow_Zone (Hide => True); |
84481f76 | 700 | Self_ID.Common.LL.Thread := pthread_self; |
84481f76 | 701 | |
5e44c5ea | 702 | Specific.Set (Self_ID); |
84481f76 RK |
703 | end Enter_Task; |
704 | ||
fbf5a39b AC |
705 | ------------------- |
706 | -- Is_Valid_Task -- | |
707 | ------------------- | |
708 | ||
709 | function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; | |
710 | ||
711 | ----------------------------- | |
712 | -- Register_Foreign_Thread -- | |
713 | ----------------------------- | |
714 | ||
b5e792e2 | 715 | function Register_Foreign_Thread return Task_Id is |
fbf5a39b AC |
716 | begin |
717 | if Is_Valid_Task then | |
718 | return Self; | |
719 | else | |
720 | return Register_Foreign_Thread (pthread_self); | |
721 | end if; | |
722 | end Register_Foreign_Thread; | |
723 | ||
84481f76 RK |
724 | -------------------- |
725 | -- Initialize_TCB -- | |
726 | -------------------- | |
727 | ||
b5e792e2 | 728 | procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is |
84481f76 RK |
729 | Mutex_Attr : aliased pthread_mutexattr_t; |
730 | Result : Interfaces.C.int; | |
731 | Cond_Attr : aliased pthread_condattr_t; | |
732 | ||
733 | begin | |
07fc65c4 GB |
734 | if not Single_Lock then |
735 | Result := pthread_mutexattr_init (Mutex_Attr'Access); | |
736 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
737 | ||
738 | if Result = 0 then | |
dae22b53 AC |
739 | Result := |
740 | pthread_mutex_init | |
741 | (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); | |
07fc65c4 GB |
742 | pragma Assert (Result = 0 or else Result = ENOMEM); |
743 | end if; | |
84481f76 | 744 | |
07fc65c4 GB |
745 | if Result /= 0 then |
746 | Succeeded := False; | |
747 | return; | |
748 | end if; | |
84481f76 | 749 | |
07fc65c4 GB |
750 | Result := pthread_mutexattr_destroy (Mutex_Attr'Access); |
751 | pragma Assert (Result = 0); | |
84481f76 RK |
752 | end if; |
753 | ||
84481f76 RK |
754 | Result := pthread_condattr_init (Cond_Attr'Access); |
755 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
756 | ||
07fc65c4 | 757 | if Result = 0 then |
dae22b53 AC |
758 | Result := |
759 | pthread_cond_init | |
760 | (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); | |
07fc65c4 | 761 | pragma Assert (Result = 0 or else Result = ENOMEM); |
84481f76 RK |
762 | end if; |
763 | ||
84481f76 RK |
764 | if Result = 0 then |
765 | Succeeded := True; | |
766 | else | |
07fc65c4 GB |
767 | if not Single_Lock then |
768 | Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); | |
769 | pragma Assert (Result = 0); | |
770 | end if; | |
771 | ||
84481f76 RK |
772 | Succeeded := False; |
773 | end if; | |
774 | ||
775 | Result := pthread_condattr_destroy (Cond_Attr'Access); | |
776 | pragma Assert (Result = 0); | |
777 | end Initialize_TCB; | |
778 | ||
779 | ----------------- | |
780 | -- Create_Task -- | |
781 | ----------------- | |
782 | ||
783 | procedure Create_Task | |
b5e792e2 | 784 | (T : Task_Id; |
84481f76 RK |
785 | Wrapper : System.Address; |
786 | Stack_Size : System.Parameters.Size_Type; | |
787 | Priority : System.Any_Priority; | |
788 | Succeeded : out Boolean) | |
789 | is | |
790 | Attributes : aliased pthread_attr_t; | |
791 | Adjusted_Stack_Size : Interfaces.C.size_t; | |
792 | Result : Interfaces.C.int; | |
793 | Param : aliased System.OS_Interface.struct_sched_param; | |
794 | ||
ec946d18 AC |
795 | Priority_Specific_Policy : constant Character := Get_Policy (Priority); |
796 | -- Upper case first character of the policy name corresponding to the | |
797 | -- task as set by a Priority_Specific_Dispatching pragma. | |
798 | ||
84481f76 RK |
799 | use System.Task_Info; |
800 | ||
801 | begin | |
f3bc3723 EB |
802 | -- Account for the Yellow Zone (2 pages) and the guard page right above. |
803 | -- See Hide_Unhide_Yellow_Zone for the rationale. | |
09c239f6 | 804 | |
57d8e34e PO |
805 | Adjusted_Stack_Size := |
806 | Interfaces.C.size_t (Stack_Size) + 3 * Get_Page_Size; | |
09c239f6 | 807 | |
84481f76 RK |
808 | Result := pthread_attr_init (Attributes'Access); |
809 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
810 | ||
811 | if Result /= 0 then | |
812 | Succeeded := False; | |
813 | return; | |
814 | end if; | |
815 | ||
dae22b53 AC |
816 | Result := |
817 | pthread_attr_setdetachstate | |
818 | (Attributes'Access, PTHREAD_CREATE_DETACHED); | |
84481f76 RK |
819 | pragma Assert (Result = 0); |
820 | ||
dae22b53 AC |
821 | Result := |
822 | pthread_attr_setstacksize | |
823 | (Attributes'Access, Adjusted_Stack_Size); | |
84481f76 RK |
824 | pragma Assert (Result = 0); |
825 | ||
826 | Param.sched_priority := | |
827 | Interfaces.C.int (Underlying_Priorities (Priority)); | |
dae22b53 AC |
828 | Result := |
829 | pthread_attr_setschedparam | |
830 | (Attributes'Access, Param'Access); | |
84481f76 RK |
831 | pragma Assert (Result = 0); |
832 | ||
ec946d18 AC |
833 | if Dispatching_Policy = 'R' |
834 | or else Priority_Specific_Policy = 'R' | |
835 | or else Time_Slice_Val > 0 | |
836 | then | |
dae22b53 AC |
837 | Result := |
838 | pthread_attr_setschedpolicy | |
839 | (Attributes'Access, System.OS_Interface.SCHED_RR); | |
84481f76 | 840 | |
ec946d18 AC |
841 | elsif Dispatching_Policy = 'F' |
842 | or else Priority_Specific_Policy = 'F' | |
843 | or else Time_Slice_Val = 0 | |
844 | then | |
dae22b53 AC |
845 | Result := |
846 | pthread_attr_setschedpolicy | |
847 | (Attributes'Access, System.OS_Interface.SCHED_FIFO); | |
84481f76 RK |
848 | |
849 | else | |
dae22b53 AC |
850 | Result := |
851 | pthread_attr_setschedpolicy | |
852 | (Attributes'Access, System.OS_Interface.SCHED_OTHER); | |
84481f76 RK |
853 | end if; |
854 | ||
855 | pragma Assert (Result = 0); | |
856 | ||
dae22b53 AC |
857 | -- Set the scheduling parameters explicitly, since this is the only way |
858 | -- to force the OS to take e.g. the sched policy and scope attributes | |
859 | -- into account. | |
fbf5a39b | 860 | |
dae22b53 AC |
861 | Result := |
862 | pthread_attr_setinheritsched | |
863 | (Attributes'Access, PTHREAD_EXPLICIT_SCHED); | |
fbf5a39b AC |
864 | pragma Assert (Result = 0); |
865 | ||
84481f76 RK |
866 | T.Common.Current_Priority := Priority; |
867 | ||
868 | if T.Common.Task_Info /= null then | |
869 | case T.Common.Task_Info.Contention_Scope is | |
870 | when System.Task_Info.Process_Scope => | |
dae22b53 AC |
871 | Result := |
872 | pthread_attr_setscope | |
873 | (Attributes'Access, PTHREAD_SCOPE_PROCESS); | |
84481f76 RK |
874 | |
875 | when System.Task_Info.System_Scope => | |
dae22b53 AC |
876 | Result := |
877 | pthread_attr_setscope | |
878 | (Attributes'Access, PTHREAD_SCOPE_SYSTEM); | |
84481f76 RK |
879 | |
880 | when System.Task_Info.Default_Scope => | |
881 | Result := 0; | |
882 | end case; | |
883 | ||
884 | pragma Assert (Result = 0); | |
885 | end if; | |
886 | ||
887 | -- Since the initial signal mask of a thread is inherited from the | |
888 | -- creator, and the Environment task has all its signals masked, we | |
889 | -- do not need to manipulate caller's signal mask at this point. | |
890 | -- All tasks in RTS will have All_Tasks_Mask initially. | |
891 | ||
bf75cdbe RO |
892 | -- Note: the use of Unrestricted_Access in the following call is needed |
893 | -- because otherwise we have an error of getting a access-to-volatile | |
894 | -- value which points to a non-volatile object. But in this case it is | |
895 | -- safe to do this, since we know we have no problems with aliasing and | |
896 | -- Unrestricted_Access bypasses this check. | |
897 | ||
dae22b53 AC |
898 | Result := |
899 | pthread_create | |
bf75cdbe | 900 | (T.Common.LL.Thread'Unrestricted_Access, |
dae22b53 AC |
901 | Attributes'Access, |
902 | Thread_Body_Access (Wrapper), | |
903 | To_Address (T)); | |
84481f76 RK |
904 | pragma Assert (Result = 0 or else Result = EAGAIN); |
905 | ||
906 | Succeeded := Result = 0; | |
907 | ||
908 | Result := pthread_attr_destroy (Attributes'Access); | |
909 | pragma Assert (Result = 0); | |
910 | ||
dc97c7a8 | 911 | if Succeeded and then T.Common.Task_Info /= null then |
dae22b53 | 912 | |
fbf5a39b AC |
913 | -- ??? We're using a process-wide function to implement a task |
914 | -- specific characteristic. | |
915 | ||
84481f76 RK |
916 | if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then |
917 | Result := bind_to_cpu (Curpid, 0); | |
dae22b53 | 918 | |
84481f76 | 919 | elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then |
dae22b53 AC |
920 | Result := |
921 | bind_to_cpu | |
922 | (Curpid, | |
923 | Interfaces.C.unsigned_long ( | |
924 | Interfaces.Shift_Left | |
925 | (Interfaces.Unsigned_64'(1), | |
926 | T.Common.Task_Info.Bind_To_Cpu_Number - 1))); | |
84481f76 RK |
927 | pragma Assert (Result = 0); |
928 | end if; | |
929 | end if; | |
930 | end Create_Task; | |
931 | ||
932 | ------------------ | |
933 | -- Finalize_TCB -- | |
934 | ------------------ | |
935 | ||
b5e792e2 | 936 | procedure Finalize_TCB (T : Task_Id) is |
f4f92d9d | 937 | Result : Interfaces.C.int; |
84481f76 RK |
938 | |
939 | begin | |
07fc65c4 GB |
940 | if not Single_Lock then |
941 | Result := pthread_mutex_destroy (T.Common.LL.L'Access); | |
942 | pragma Assert (Result = 0); | |
943 | end if; | |
944 | ||
84481f76 RK |
945 | Result := pthread_cond_destroy (T.Common.LL.CV'Access); |
946 | pragma Assert (Result = 0); | |
07fc65c4 | 947 | |
84481f76 RK |
948 | if T.Known_Tasks_Index /= -1 then |
949 | Known_Tasks (T.Known_Tasks_Index) := null; | |
950 | end if; | |
07fc65c4 | 951 | |
f4f92d9d | 952 | ATCB_Allocation.Free_ATCB (T); |
84481f76 RK |
953 | end Finalize_TCB; |
954 | ||
955 | --------------- | |
956 | -- Exit_Task -- | |
957 | --------------- | |
958 | ||
959 | procedure Exit_Task is | |
960 | begin | |
fbf5a39b | 961 | Specific.Set (null); |
f3bc3723 | 962 | Hide_Unhide_Yellow_Zone (Hide => False); |
84481f76 RK |
963 | end Exit_Task; |
964 | ||
965 | ---------------- | |
966 | -- Abort_Task -- | |
967 | ---------------- | |
968 | ||
b5e792e2 | 969 | procedure Abort_Task (T : Task_Id) is |
84481f76 | 970 | Result : Interfaces.C.int; |
84481f76 | 971 | begin |
658cea5b AC |
972 | if Abort_Handler_Installed then |
973 | Result := pthread_kill (T.Common.LL.Thread, | |
974 | Signal (System.Interrupt_Management.Abort_Task_Interrupt)); | |
975 | pragma Assert (Result = 0); | |
976 | end if; | |
84481f76 RK |
977 | end Abort_Task; |
978 | ||
b497b460 JR |
979 | ---------------- |
980 | -- Initialize -- | |
981 | ---------------- | |
982 | ||
983 | procedure Initialize (S : in out Suspension_Object) is | |
984 | Mutex_Attr : aliased pthread_mutexattr_t; | |
985 | Cond_Attr : aliased pthread_condattr_t; | |
986 | Result : Interfaces.C.int; | |
dae22b53 | 987 | |
b497b460 | 988 | begin |
dae22b53 | 989 | -- Initialize internal state (always to False (RM D.10(6))) |
b497b460 JR |
990 | |
991 | S.State := False; | |
992 | S.Waiting := False; | |
993 | ||
994 | -- Initialize internal mutex | |
995 | ||
996 | Result := pthread_mutexattr_init (Mutex_Attr'Access); | |
997 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
998 | ||
999 | if Result = ENOMEM then | |
1000 | raise Storage_Error; | |
1001 | end if; | |
1002 | ||
1003 | Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); | |
1004 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
1005 | ||
1006 | if Result = ENOMEM then | |
1007 | Result := pthread_mutexattr_destroy (Mutex_Attr'Access); | |
1008 | raise Storage_Error; | |
1009 | end if; | |
1010 | ||
1011 | Result := pthread_mutexattr_destroy (Mutex_Attr'Access); | |
1012 | pragma Assert (Result = 0); | |
1013 | ||
1014 | -- Initialize internal condition variable | |
1015 | ||
1016 | Result := pthread_condattr_init (Cond_Attr'Access); | |
1017 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
1018 | ||
1019 | Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); | |
1020 | ||
1021 | pragma Assert (Result = 0 or else Result = ENOMEM); | |
1022 | ||
1023 | if Result /= 0 then | |
1024 | Result := pthread_mutex_destroy (S.L'Access); | |
1025 | pragma Assert (Result = 0); | |
1026 | ||
1027 | if Result = ENOMEM then | |
1028 | raise Storage_Error; | |
1029 | end if; | |
1030 | end if; | |
1031 | end Initialize; | |
1032 | ||
1033 | -------------- | |
1034 | -- Finalize -- | |
1035 | -------------- | |
1036 | ||
1037 | procedure Finalize (S : in out Suspension_Object) is | |
1038 | Result : Interfaces.C.int; | |
dae22b53 | 1039 | |
b497b460 JR |
1040 | begin |
1041 | -- Destroy internal mutex | |
1042 | ||
1043 | Result := pthread_mutex_destroy (S.L'Access); | |
1044 | pragma Assert (Result = 0); | |
1045 | ||
1046 | -- Destroy internal condition variable | |
1047 | ||
1048 | Result := pthread_cond_destroy (S.CV'Access); | |
1049 | pragma Assert (Result = 0); | |
1050 | end Finalize; | |
1051 | ||
1052 | ------------------- | |
1053 | -- Current_State -- | |
1054 | ------------------- | |
1055 | ||
1056 | function Current_State (S : Suspension_Object) return Boolean is | |
1057 | begin | |
1058 | -- We do not want to use lock on this read operation. State is marked | |
1059 | -- as Atomic so that we ensure that the value retrieved is correct. | |
1060 | ||
1061 | return S.State; | |
1062 | end Current_State; | |
1063 | ||
1064 | --------------- | |
1065 | -- Set_False -- | |
1066 | --------------- | |
1067 | ||
1068 | procedure Set_False (S : in out Suspension_Object) is | |
1069 | Result : Interfaces.C.int; | |
dae22b53 | 1070 | |
b497b460 | 1071 | begin |
72774950 JR |
1072 | SSL.Abort_Defer.all; |
1073 | ||
b497b460 JR |
1074 | Result := pthread_mutex_lock (S.L'Access); |
1075 | pragma Assert (Result = 0); | |
1076 | ||
1077 | S.State := False; | |
1078 | ||
1079 | Result := pthread_mutex_unlock (S.L'Access); | |
1080 | pragma Assert (Result = 0); | |
72774950 JR |
1081 | |
1082 | SSL.Abort_Undefer.all; | |
b497b460 JR |
1083 | end Set_False; |
1084 | ||
1085 | -------------- | |
1086 | -- Set_True -- | |
1087 | -------------- | |
1088 | ||
1089 | procedure Set_True (S : in out Suspension_Object) is | |
1090 | Result : Interfaces.C.int; | |
dae22b53 | 1091 | |
b497b460 | 1092 | begin |
72774950 JR |
1093 | SSL.Abort_Defer.all; |
1094 | ||
b497b460 JR |
1095 | Result := pthread_mutex_lock (S.L'Access); |
1096 | pragma Assert (Result = 0); | |
1097 | ||
dae22b53 AC |
1098 | -- If there is already a task waiting on this suspension object then we |
1099 | -- resume it, leaving the state of the suspension object to False, as | |
1100 | -- specified in (RM D.10(9)). Otherwise, leave the state set to True. | |
b497b460 JR |
1101 | |
1102 | if S.Waiting then | |
1103 | S.Waiting := False; | |
1104 | S.State := False; | |
1105 | ||
1106 | Result := pthread_cond_signal (S.CV'Access); | |
1107 | pragma Assert (Result = 0); | |
dae22b53 | 1108 | |
b497b460 JR |
1109 | else |
1110 | S.State := True; | |
1111 | end if; | |
1112 | ||
1113 | Result := pthread_mutex_unlock (S.L'Access); | |
1114 | pragma Assert (Result = 0); | |
72774950 JR |
1115 | |
1116 | SSL.Abort_Undefer.all; | |
b497b460 JR |
1117 | end Set_True; |
1118 | ||
1119 | ------------------------ | |
1120 | -- Suspend_Until_True -- | |
1121 | ------------------------ | |
1122 | ||
1123 | procedure Suspend_Until_True (S : in out Suspension_Object) is | |
1124 | Result : Interfaces.C.int; | |
dae22b53 | 1125 | |
b497b460 | 1126 | begin |
72774950 JR |
1127 | SSL.Abort_Defer.all; |
1128 | ||
b497b460 JR |
1129 | Result := pthread_mutex_lock (S.L'Access); |
1130 | pragma Assert (Result = 0); | |
1131 | ||
1132 | if S.Waiting then | |
dae22b53 | 1133 | |
b497b460 JR |
1134 | -- Program_Error must be raised upon calling Suspend_Until_True |
1135 | -- if another task is already waiting on that suspension object | |
dae22b53 | 1136 | -- (AM D.10(10)). |
b497b460 JR |
1137 | |
1138 | Result := pthread_mutex_unlock (S.L'Access); | |
1139 | pragma Assert (Result = 0); | |
1140 | ||
72774950 JR |
1141 | SSL.Abort_Undefer.all; |
1142 | ||
b497b460 | 1143 | raise Program_Error; |
dae22b53 | 1144 | |
b497b460 JR |
1145 | else |
1146 | -- Suspend the task if the state is False. Otherwise, the task | |
1147 | -- continues its execution, and the state of the suspension object | |
dae22b53 | 1148 | -- is set to False (RM D.10(9)). |
b497b460 JR |
1149 | |
1150 | if S.State then | |
1151 | S.State := False; | |
1152 | else | |
1153 | S.Waiting := True; | |
a8f59a33 AC |
1154 | |
1155 | loop | |
7e728b0f TQ |
1156 | -- Loop in case pthread_cond_wait returns earlier than expected |
1157 | -- (e.g. in case of EINTR caused by a signal). | |
a8f59a33 AC |
1158 | |
1159 | Result := pthread_cond_wait (S.CV'Access, S.L'Access); | |
1160 | pragma Assert (Result = 0 or else Result = EINTR); | |
1161 | ||
1162 | exit when not S.Waiting; | |
1163 | end loop; | |
b497b460 | 1164 | end if; |
b497b460 | 1165 | |
72774950 JR |
1166 | Result := pthread_mutex_unlock (S.L'Access); |
1167 | pragma Assert (Result = 0); | |
1168 | ||
1169 | SSL.Abort_Undefer.all; | |
1170 | end if; | |
b497b460 JR |
1171 | end Suspend_Until_True; |
1172 | ||
84481f76 RK |
1173 | ---------------- |
1174 | -- Check_Exit -- | |
1175 | ---------------- | |
1176 | ||
fbf5a39b | 1177 | -- Dummy version |
84481f76 | 1178 | |
b5e792e2 | 1179 | function Check_Exit (Self_ID : ST.Task_Id) return Boolean is |
fbf5a39b | 1180 | pragma Unreferenced (Self_ID); |
84481f76 RK |
1181 | begin |
1182 | return True; | |
1183 | end Check_Exit; | |
1184 | ||
1185 | -------------------- | |
1186 | -- Check_No_Locks -- | |
1187 | -------------------- | |
1188 | ||
b5e792e2 | 1189 | function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is |
fbf5a39b | 1190 | pragma Unreferenced (Self_ID); |
84481f76 RK |
1191 | begin |
1192 | return True; | |
1193 | end Check_No_Locks; | |
1194 | ||
1195 | ---------------------- | |
1196 | -- Environment_Task -- | |
1197 | ---------------------- | |
1198 | ||
b5e792e2 | 1199 | function Environment_Task return Task_Id is |
84481f76 | 1200 | begin |
b5e792e2 | 1201 | return Environment_Task_Id; |
84481f76 RK |
1202 | end Environment_Task; |
1203 | ||
07fc65c4 GB |
1204 | -------------- |
1205 | -- Lock_RTS -- | |
1206 | -------------- | |
84481f76 | 1207 | |
07fc65c4 | 1208 | procedure Lock_RTS is |
84481f76 | 1209 | begin |
07fc65c4 GB |
1210 | Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); |
1211 | end Lock_RTS; | |
84481f76 | 1212 | |
07fc65c4 GB |
1213 | ---------------- |
1214 | -- Unlock_RTS -- | |
1215 | ---------------- | |
84481f76 | 1216 | |
07fc65c4 | 1217 | procedure Unlock_RTS is |
84481f76 | 1218 | begin |
07fc65c4 GB |
1219 | Unlock (Single_RTS_Lock'Access, Global_Lock => True); |
1220 | end Unlock_RTS; | |
84481f76 RK |
1221 | |
1222 | ------------------ | |
1223 | -- Suspend_Task -- | |
1224 | ------------------ | |
1225 | ||
1226 | function Suspend_Task | |
b5e792e2 | 1227 | (T : ST.Task_Id; |
91b1417d | 1228 | Thread_Self : Thread_Id) return Boolean |
fbf5a39b | 1229 | is |
dae22b53 | 1230 | pragma Unreferenced (T, Thread_Self); |
84481f76 RK |
1231 | begin |
1232 | return False; | |
1233 | end Suspend_Task; | |
1234 | ||
1235 | ----------------- | |
1236 | -- Resume_Task -- | |
1237 | ----------------- | |
1238 | ||
1239 | function Resume_Task | |
b5e792e2 | 1240 | (T : ST.Task_Id; |
91b1417d | 1241 | Thread_Self : Thread_Id) return Boolean |
fbf5a39b | 1242 | is |
dae22b53 | 1243 | pragma Unreferenced (T, Thread_Self); |
84481f76 RK |
1244 | begin |
1245 | return False; | |
1246 | end Resume_Task; | |
1247 | ||
c9b9ec14 JG |
1248 | -------------------- |
1249 | -- Stop_All_Tasks -- | |
1250 | -------------------- | |
1251 | ||
1252 | procedure Stop_All_Tasks is | |
1253 | begin | |
1254 | null; | |
1255 | end Stop_All_Tasks; | |
1256 | ||
ed18d858 JG |
1257 | --------------- |
1258 | -- Stop_Task -- | |
1259 | --------------- | |
1260 | ||
1261 | function Stop_Task (T : ST.Task_Id) return Boolean is | |
1262 | pragma Unreferenced (T); | |
1263 | begin | |
1264 | return False; | |
1265 | end Stop_Task; | |
1266 | ||
c9b9ec14 JG |
1267 | ------------------- |
1268 | -- Continue_Task -- | |
1269 | ------------------- | |
1270 | ||
1271 | function Continue_Task (T : ST.Task_Id) return Boolean is | |
1272 | pragma Unreferenced (T); | |
1273 | begin | |
1274 | return False; | |
1275 | end Continue_Task; | |
1276 | ||
84481f76 RK |
1277 | ---------------- |
1278 | -- Initialize -- | |
1279 | ---------------- | |
1280 | ||
b5e792e2 | 1281 | procedure Initialize (Environment_Task : Task_Id) is |
fbf5a39b AC |
1282 | act : aliased struct_sigaction; |
1283 | old_act : aliased struct_sigaction; | |
1284 | Tmp_Set : aliased sigset_t; | |
1285 | Result : Interfaces.C.int; | |
1286 | ||
91b1417d AC |
1287 | function State |
1288 | (Int : System.Interrupt_Management.Interrupt_ID) return Character; | |
fbf5a39b | 1289 | pragma Import (C, State, "__gnat_get_interrupt_state"); |
91b1417d AC |
1290 | -- Get interrupt state. Defined in a-init.c. The input argument is |
1291 | -- the interrupt number, and the result is one of the following: | |
fbf5a39b AC |
1292 | |
1293 | Default : constant Character := 's'; | |
1294 | -- 'n' this interrupt not set by any Interrupt_State pragma | |
1295 | -- 'u' Interrupt_State pragma set state to User | |
1296 | -- 'r' Interrupt_State pragma set state to Runtime | |
1297 | -- 's' Interrupt_State pragma set state to System (use "default" | |
1298 | -- system handler) | |
84481f76 RK |
1299 | |
1300 | begin | |
b5e792e2 | 1301 | Environment_Task_Id := Environment_Task; |
84481f76 | 1302 | |
3b91d88e AC |
1303 | Interrupt_Management.Initialize; |
1304 | ||
1305 | -- Prepare the set of signals that should unblocked in all tasks | |
1306 | ||
1307 | Result := sigemptyset (Unblocked_Signal_Mask'Access); | |
1308 | pragma Assert (Result = 0); | |
1309 | ||
1310 | for J in Interrupt_Management.Interrupt_ID loop | |
1311 | if System.Interrupt_Management.Keep_Unmasked (J) then | |
1312 | Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); | |
1313 | pragma Assert (Result = 0); | |
1314 | end if; | |
1315 | end loop; | |
1316 | ||
1317 | Curpid := getpid; | |
1318 | ||
09c239f6 | 1319 | -- Initialize the lock used to synchronize chain of all ATCBs |
84481f76 | 1320 | |
fbf5a39b AC |
1321 | Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); |
1322 | ||
84481f76 RK |
1323 | Specific.Initialize (Environment_Task); |
1324 | ||
3204b9cd AC |
1325 | -- Make environment task known here because it doesn't go through |
1326 | -- Activate_Tasks, which does it for all other tasks. | |
1327 | ||
1328 | Known_Tasks (Known_Tasks'First) := Environment_Task; | |
1329 | Environment_Task.Known_Tasks_Index := Known_Tasks'First; | |
1330 | ||
84481f76 RK |
1331 | Enter_Task (Environment_Task); |
1332 | ||
dae22b53 AC |
1333 | if State |
1334 | (System.Interrupt_Management.Abort_Task_Interrupt) /= Default | |
fbf5a39b AC |
1335 | then |
1336 | act.sa_flags := 0; | |
1337 | act.sa_handler := Abort_Handler'Address; | |
84481f76 | 1338 | |
fbf5a39b AC |
1339 | Result := sigemptyset (Tmp_Set'Access); |
1340 | pragma Assert (Result = 0); | |
1341 | act.sa_mask := Tmp_Set; | |
84481f76 | 1342 | |
fbf5a39b AC |
1343 | Result := |
1344 | sigaction | |
dae22b53 AC |
1345 | (Signal (System.Interrupt_Management.Abort_Task_Interrupt), |
1346 | act'Unchecked_Access, | |
1347 | old_act'Unchecked_Access); | |
fbf5a39b | 1348 | pragma Assert (Result = 0); |
658cea5b | 1349 | Abort_Handler_Installed := True; |
fbf5a39b | 1350 | end if; |
84481f76 RK |
1351 | end Initialize; |
1352 | ||
c37cbdc3 AC |
1353 | ----------------------- |
1354 | -- Set_Task_Affinity -- | |
1355 | ----------------------- | |
1356 | ||
1357 | procedure Set_Task_Affinity (T : ST.Task_Id) is | |
1358 | pragma Unreferenced (T); | |
7cda9727 | 1359 | |
c37cbdc3 AC |
1360 | begin |
1361 | -- Setting task affinity is not supported by the underlying system | |
1362 | ||
1363 | null; | |
1364 | end Set_Task_Affinity; | |
84481f76 | 1365 | end System.Task_Primitives.Operations; |