File : s-taprop-posix.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) 1992-2015, 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 -- --
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 -- 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 POSIX-like version of this package
33
34 -- This package contains all the GNULL primitives that interface directly with
35 -- the underlying OS.
36
37 -- Note: this file can only be used for POSIX compliant systems that implement
38 -- SCHED_FIFO and Ceiling Locking correctly.
39
40 -- For configurations where SCHED_FIFO and priority ceiling are not a
41 -- requirement, this file can also be used (e.g AiX threads)
42
43 pragma Polling (Off);
44 -- Turn off polling, we do not want ATC polling to take place during tasking
45 -- operations. It causes infinite loops and other problems.
46
47 with Ada.Unchecked_Conversion;
48
49 with Interfaces.C;
50
51 with System.Tasking.Debug;
52 with System.Interrupt_Management;
53 with System.OS_Constants;
54 with System.OS_Primitives;
55 with System.Task_Info;
56
57 with System.Soft_Links;
58 -- We use System.Soft_Links instead of System.Tasking.Initialization
59 -- because the later is a higher level package that we shouldn't depend on.
60 -- For example when using the restricted run time, it is replaced by
61 -- System.Tasking.Restricted.Stages.
62
63 package body System.Task_Primitives.Operations is
64
65 package OSC renames System.OS_Constants;
66 package SSL renames System.Soft_Links;
67
68 use System.Tasking.Debug;
69 use System.Tasking;
70 use Interfaces.C;
71 use System.OS_Interface;
72 use System.Parameters;
73 use System.OS_Primitives;
74
75 ----------------
76 -- Local Data --
77 ----------------
78
79 -- The followings are logically constants, but need to be initialized
80 -- at run time.
81
82 Single_RTS_Lock : aliased RTS_Lock;
83 -- This is a lock to allow only one thread of control in the RTS at
84 -- a time; it is used to execute in mutual exclusion from all other tasks.
85 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
86
87 Environment_Task_Id : Task_Id;
88 -- A variable to hold Task_Id for the environment task
89
90 Locking_Policy : Character;
91 pragma Import (C, Locking_Policy, "__gl_locking_policy");
92 -- Value of the pragma Locking_Policy:
93 -- 'C' for Ceiling_Locking
94 -- 'I' for Inherit_Locking
95 -- ' ' for none.
96
97 Unblocked_Signal_Mask : aliased sigset_t;
98 -- The set of signals that should unblocked in all tasks
99
100 -- The followings are internal configuration constants needed
101
102 Next_Serial_Number : Task_Serial_Number := 100;
103 -- We start at 100, to reserve some special values for
104 -- using in error checking.
105
106 Time_Slice_Val : Integer;
107 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
108
109 Dispatching_Policy : Character;
110 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
111
112 Foreign_Task_Elaborated : aliased Boolean := True;
113 -- Used to identified fake tasks (i.e., non-Ada Threads)
114
115 Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
116 -- Whether to use an alternate signal stack for stack overflows
117
118 Abort_Handler_Installed : Boolean := False;
119 -- True if a handler for the abort signal is installed
120
121 --------------------
122 -- Local Packages --
123 --------------------
124
125 package Specific is
126
127 procedure Initialize (Environment_Task : Task_Id);
128 pragma Inline (Initialize);
129 -- Initialize various data needed by this package
130
131 function Is_Valid_Task return Boolean;
132 pragma Inline (Is_Valid_Task);
133 -- Does executing thread have a TCB?
134
135 procedure Set (Self_Id : Task_Id);
136 pragma Inline (Set);
137 -- Set the self id for the current task
138
139 function Self return Task_Id;
140 pragma Inline (Self);
141 -- Return a pointer to the Ada Task Control Block of the calling task
142
143 end Specific;
144
145 package body Specific is separate;
146 -- The body of this package is target specific
147
148 ----------------------------------
149 -- ATCB allocation/deallocation --
150 ----------------------------------
151
152 package body ATCB_Allocation is separate;
153 -- The body of this package is shared across several targets
154
155 ---------------------------------
156 -- Support for foreign threads --
157 ---------------------------------
158
159 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
160 -- Allocate and Initialize a new ATCB for the current Thread
161
162 function Register_Foreign_Thread
163 (Thread : Thread_Id) return Task_Id is separate;
164
165 -----------------------
166 -- Local Subprograms --
167 -----------------------
168
169 procedure Abort_Handler (Sig : Signal);
170 -- Signal handler used to implement asynchronous abort.
171 -- See also comment before body, below.
172
173 function To_Address is
174 new Ada.Unchecked_Conversion (Task_Id, System.Address);
175
176 function GNAT_pthread_condattr_setup
177 (attr : access pthread_condattr_t) return int;
178 pragma Import (C,
179 GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
180
181 procedure Compute_Deadline
182 (Time : Duration;
183 Mode : ST.Delay_Modes;
184 Check_Time : out Duration;
185 Abs_Time : out Duration;
186 Rel_Time : out Duration);
187 -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by
188 -- Time and Mode, compute the current clock reading (Check_Time), and the
189 -- target absolute and relative clock readings (Abs_Time, Rel_Time). The
190 -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time
191 -- is always that of CLOCK_RT_Ada.
192
193 -------------------
194 -- Abort_Handler --
195 -------------------
196
197 -- Target-dependent binding of inter-thread Abort signal to the raising of
198 -- the Abort_Signal exception.
199
200 -- The technical issues and alternatives here are essentially the
201 -- same as for raising exceptions in response to other signals
202 -- (e.g. Storage_Error). See code and comments in the package body
203 -- System.Interrupt_Management.
204
205 -- Some implementations may not allow an exception to be propagated out of
206 -- a handler, and others might leave the signal or interrupt that invoked
207 -- this handler masked after the exceptional return to the application
208 -- code.
209
210 -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On
211 -- most UNIX systems, this will allow transfer out of a signal handler,
212 -- which is usually the only mechanism available for implementing
213 -- asynchronous handlers of this kind. However, some systems do not
214 -- restore the signal mask on longjmp(), leaving the abort signal masked.
215
216 procedure Abort_Handler (Sig : Signal) is
217 pragma Unreferenced (Sig);
218
219 T : constant Task_Id := Self;
220 Old_Set : aliased sigset_t;
221
222 Result : Interfaces.C.int;
223 pragma Warnings (Off, Result);
224
225 begin
226 -- It's not safe to raise an exception when using GCC ZCX mechanism.
227 -- Note that we still need to install a signal handler, since in some
228 -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
229 -- need to send the Abort signal to a task.
230
231 if ZCX_By_Default then
232 return;
233 end if;
234
235 if T.Deferral_Level = 0
236 and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
237 not T.Aborting
238 then
239 T.Aborting := True;
240
241 -- Make sure signals used for RTS internal purpose are unmasked
242
243 Result := pthread_sigmask (SIG_UNBLOCK,
244 Unblocked_Signal_Mask'Access, Old_Set'Access);
245 pragma Assert (Result = 0);
246
247 raise Standard'Abort_Signal;
248 end if;
249 end Abort_Handler;
250
251 ----------------------
252 -- Compute_Deadline --
253 ----------------------
254
255 procedure Compute_Deadline
256 (Time : Duration;
257 Mode : ST.Delay_Modes;
258 Check_Time : out Duration;
259 Abs_Time : out Duration;
260 Rel_Time : out Duration)
261 is
262 begin
263 Check_Time := Monotonic_Clock;
264
265 -- Relative deadline
266
267 if Mode = Relative then
268 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
269
270 if Relative_Timed_Wait then
271 Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
272 end if;
273
274 pragma Warnings (Off);
275 -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile
276 -- time known.
277
278 -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada)
279
280 elsif Mode = Absolute_RT
281 or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME
282 then
283 pragma Warnings (On);
284 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
285
286 if Relative_Timed_Wait then
287 Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
288 end if;
289
290 -- Absolute deadline specified using the calendar clock, in the
291 -- case where it is not the same as the tasking clock: compensate for
292 -- difference between clock epochs (Base_Time - Base_Cal_Time).
293
294 else
295 declare
296 Cal_Check_Time : constant Duration := OS_Primitives.Clock;
297 RT_Time : constant Duration :=
298 Time + Check_Time - Cal_Check_Time;
299
300 begin
301 Abs_Time :=
302 Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time);
303
304 if Relative_Timed_Wait then
305 Rel_Time :=
306 Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time);
307 end if;
308 end;
309 end if;
310 end Compute_Deadline;
311
312 -----------------
313 -- Stack_Guard --
314 -----------------
315
316 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
317 Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
318 Page_Size : Address;
319 Res : Interfaces.C.int;
320
321 begin
322 if Stack_Base_Available then
323
324 -- Compute the guard page address
325
326 Page_Size := Address (Get_Page_Size);
327 Res :=
328 mprotect
329 (Stack_Base - (Stack_Base mod Page_Size) + Page_Size,
330 size_t (Page_Size),
331 prot => (if On then PROT_ON else PROT_OFF));
332 pragma Assert (Res = 0);
333 end if;
334 end Stack_Guard;
335
336 --------------------
337 -- Get_Thread_Id --
338 --------------------
339
340 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
341 begin
342 return T.Common.LL.Thread;
343 end Get_Thread_Id;
344
345 ----------
346 -- Self --
347 ----------
348
349 function Self return Task_Id renames Specific.Self;
350
351 ---------------------
352 -- Initialize_Lock --
353 ---------------------
354
355 -- Note: mutexes and cond_variables needed per-task basis are
356 -- initialized in Initialize_TCB and the Storage_Error is
357 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
358 -- used in RTS is initialized before any status change of RTS.
359 -- Therefore raising Storage_Error in the following routines
360 -- should be able to be handled safely.
361
362 procedure Initialize_Lock
363 (Prio : System.Any_Priority;
364 L : not null access Lock)
365 is
366 Attributes : aliased pthread_mutexattr_t;
367 Result : Interfaces.C.int;
368
369 begin
370 Result := pthread_mutexattr_init (Attributes'Access);
371 pragma Assert (Result = 0 or else Result = ENOMEM);
372
373 if Result = ENOMEM then
374 raise Storage_Error;
375 end if;
376
377 if Locking_Policy = 'C' then
378 Result := pthread_mutexattr_setprotocol
379 (Attributes'Access, PTHREAD_PRIO_PROTECT);
380 pragma Assert (Result = 0);
381
382 Result := pthread_mutexattr_setprioceiling
383 (Attributes'Access, Interfaces.C.int (Prio));
384 pragma Assert (Result = 0);
385
386 elsif Locking_Policy = 'I' then
387 Result := pthread_mutexattr_setprotocol
388 (Attributes'Access, PTHREAD_PRIO_INHERIT);
389 pragma Assert (Result = 0);
390 end if;
391
392 Result := pthread_mutex_init (L.WO'Access, Attributes'Access);
393 pragma Assert (Result = 0 or else Result = ENOMEM);
394
395 if Result = ENOMEM then
396 Result := pthread_mutexattr_destroy (Attributes'Access);
397 raise Storage_Error;
398 end if;
399
400 Result := pthread_mutexattr_destroy (Attributes'Access);
401 pragma Assert (Result = 0);
402 end Initialize_Lock;
403
404 procedure Initialize_Lock
405 (L : not null access RTS_Lock; Level : Lock_Level)
406 is
407 pragma Unreferenced (Level);
408
409 Attributes : aliased pthread_mutexattr_t;
410 Result : Interfaces.C.int;
411
412 begin
413 Result := pthread_mutexattr_init (Attributes'Access);
414 pragma Assert (Result = 0 or else Result = ENOMEM);
415
416 if Result = ENOMEM then
417 raise Storage_Error;
418 end if;
419
420 if Locking_Policy = 'C' then
421 Result := pthread_mutexattr_setprotocol
422 (Attributes'Access, PTHREAD_PRIO_PROTECT);
423 pragma Assert (Result = 0);
424
425 Result := pthread_mutexattr_setprioceiling
426 (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
427 pragma Assert (Result = 0);
428
429 elsif Locking_Policy = 'I' then
430 Result := pthread_mutexattr_setprotocol
431 (Attributes'Access, PTHREAD_PRIO_INHERIT);
432 pragma Assert (Result = 0);
433 end if;
434
435 Result := pthread_mutex_init (L, Attributes'Access);
436 pragma Assert (Result = 0 or else Result = ENOMEM);
437
438 if Result = ENOMEM then
439 Result := pthread_mutexattr_destroy (Attributes'Access);
440 raise Storage_Error;
441 end if;
442
443 Result := pthread_mutexattr_destroy (Attributes'Access);
444 pragma Assert (Result = 0);
445 end Initialize_Lock;
446
447 -------------------
448 -- Finalize_Lock --
449 -------------------
450
451 procedure Finalize_Lock (L : not null access Lock) is
452 Result : Interfaces.C.int;
453 begin
454 Result := pthread_mutex_destroy (L.WO'Access);
455 pragma Assert (Result = 0);
456 end Finalize_Lock;
457
458 procedure Finalize_Lock (L : not null access RTS_Lock) is
459 Result : Interfaces.C.int;
460 begin
461 Result := pthread_mutex_destroy (L);
462 pragma Assert (Result = 0);
463 end Finalize_Lock;
464
465 ----------------
466 -- Write_Lock --
467 ----------------
468
469 procedure Write_Lock
470 (L : not null access Lock; Ceiling_Violation : out Boolean)
471 is
472 Result : Interfaces.C.int;
473
474 begin
475 Result := pthread_mutex_lock (L.WO'Access);
476
477 -- Assume that the cause of EINVAL is a priority ceiling violation
478
479 Ceiling_Violation := (Result = EINVAL);
480 pragma Assert (Result = 0 or else Result = EINVAL);
481 end Write_Lock;
482
483 procedure Write_Lock
484 (L : not null access RTS_Lock;
485 Global_Lock : Boolean := False)
486 is
487 Result : Interfaces.C.int;
488 begin
489 if not Single_Lock or else Global_Lock then
490 Result := pthread_mutex_lock (L);
491 pragma Assert (Result = 0);
492 end if;
493 end Write_Lock;
494
495 procedure Write_Lock (T : Task_Id) is
496 Result : Interfaces.C.int;
497 begin
498 if not Single_Lock then
499 Result := pthread_mutex_lock (T.Common.LL.L'Access);
500 pragma Assert (Result = 0);
501 end if;
502 end Write_Lock;
503
504 ---------------
505 -- Read_Lock --
506 ---------------
507
508 procedure Read_Lock
509 (L : not null access Lock; Ceiling_Violation : out Boolean) is
510 begin
511 Write_Lock (L, Ceiling_Violation);
512 end Read_Lock;
513
514 ------------
515 -- Unlock --
516 ------------
517
518 procedure Unlock (L : not null access Lock) is
519 Result : Interfaces.C.int;
520 begin
521 Result := pthread_mutex_unlock (L.WO'Access);
522 pragma Assert (Result = 0);
523 end Unlock;
524
525 procedure Unlock
526 (L : not null access RTS_Lock; Global_Lock : Boolean := False)
527 is
528 Result : Interfaces.C.int;
529 begin
530 if not Single_Lock or else Global_Lock then
531 Result := pthread_mutex_unlock (L);
532 pragma Assert (Result = 0);
533 end if;
534 end Unlock;
535
536 procedure Unlock (T : Task_Id) is
537 Result : Interfaces.C.int;
538 begin
539 if not Single_Lock then
540 Result := pthread_mutex_unlock (T.Common.LL.L'Access);
541 pragma Assert (Result = 0);
542 end if;
543 end Unlock;
544
545 -----------------
546 -- Set_Ceiling --
547 -----------------
548
549 -- Dynamic priority ceilings are not supported by the underlying system
550
551 procedure Set_Ceiling
552 (L : not null access Lock;
553 Prio : System.Any_Priority)
554 is
555 pragma Unreferenced (L, Prio);
556 begin
557 null;
558 end Set_Ceiling;
559
560 -----------
561 -- Sleep --
562 -----------
563
564 procedure Sleep
565 (Self_ID : Task_Id;
566 Reason : System.Tasking.Task_States)
567 is
568 pragma Unreferenced (Reason);
569
570 Result : Interfaces.C.int;
571
572 begin
573 Result :=
574 pthread_cond_wait
575 (cond => Self_ID.Common.LL.CV'Access,
576 mutex => (if Single_Lock
577 then Single_RTS_Lock'Access
578 else Self_ID.Common.LL.L'Access));
579
580 -- EINTR is not considered a failure
581
582 pragma Assert (Result = 0 or else Result = EINTR);
583 end Sleep;
584
585 -----------------
586 -- Timed_Sleep --
587 -----------------
588
589 -- This is for use within the run-time system, so abort is
590 -- assumed to be already deferred, and the caller should be
591 -- holding its own ATCB lock.
592
593 procedure Timed_Sleep
594 (Self_ID : Task_Id;
595 Time : Duration;
596 Mode : ST.Delay_Modes;
597 Reason : Task_States;
598 Timedout : out Boolean;
599 Yielded : out Boolean)
600 is
601 pragma Unreferenced (Reason);
602
603 Base_Time : Duration;
604 Check_Time : Duration;
605 Abs_Time : Duration;
606 Rel_Time : Duration;
607
608 Request : aliased timespec;
609 Result : Interfaces.C.int;
610
611 begin
612 Timedout := True;
613 Yielded := False;
614
615 Compute_Deadline
616 (Time => Time,
617 Mode => Mode,
618 Check_Time => Check_Time,
619 Abs_Time => Abs_Time,
620 Rel_Time => Rel_Time);
621 Base_Time := Check_Time;
622
623 if Abs_Time > Check_Time then
624 Request :=
625 To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
626
627 loop
628 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
629
630 Result :=
631 pthread_cond_timedwait
632 (cond => Self_ID.Common.LL.CV'Access,
633 mutex => (if Single_Lock
634 then Single_RTS_Lock'Access
635 else Self_ID.Common.LL.L'Access),
636 abstime => Request'Access);
637
638 Check_Time := Monotonic_Clock;
639 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
640
641 if Result = 0 or Result = EINTR then
642
643 -- Somebody may have called Wakeup for us
644
645 Timedout := False;
646 exit;
647 end if;
648
649 pragma Assert (Result = ETIMEDOUT);
650 end loop;
651 end if;
652 end Timed_Sleep;
653
654 -----------------
655 -- Timed_Delay --
656 -----------------
657
658 -- This is for use in implementing delay statements, so we assume the
659 -- caller is abort-deferred but is holding no locks.
660
661 procedure Timed_Delay
662 (Self_ID : Task_Id;
663 Time : Duration;
664 Mode : ST.Delay_Modes)
665 is
666 Base_Time : Duration;
667 Check_Time : Duration;
668 Abs_Time : Duration;
669 Rel_Time : Duration;
670 Request : aliased timespec;
671
672 Result : Interfaces.C.int;
673 pragma Warnings (Off, Result);
674
675 begin
676 if Single_Lock then
677 Lock_RTS;
678 end if;
679
680 Write_Lock (Self_ID);
681
682 Compute_Deadline
683 (Time => Time,
684 Mode => Mode,
685 Check_Time => Check_Time,
686 Abs_Time => Abs_Time,
687 Rel_Time => Rel_Time);
688 Base_Time := Check_Time;
689
690 if Abs_Time > Check_Time then
691 Request :=
692 To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
693 Self_ID.Common.State := Delay_Sleep;
694
695 loop
696 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
697
698 Result :=
699 pthread_cond_timedwait
700 (cond => Self_ID.Common.LL.CV'Access,
701 mutex => (if Single_Lock
702 then Single_RTS_Lock'Access
703 else Self_ID.Common.LL.L'Access),
704 abstime => Request'Access);
705
706 Check_Time := Monotonic_Clock;
707 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
708
709 pragma Assert (Result = 0
710 or else Result = ETIMEDOUT
711 or else Result = EINTR);
712 end loop;
713
714 Self_ID.Common.State := Runnable;
715 end if;
716
717 Unlock (Self_ID);
718
719 if Single_Lock then
720 Unlock_RTS;
721 end if;
722
723 Result := sched_yield;
724 end Timed_Delay;
725
726 ---------------------
727 -- Monotonic_Clock --
728 ---------------------
729
730 function Monotonic_Clock return Duration is
731 TS : aliased timespec;
732 Result : Interfaces.C.int;
733 begin
734 Result := clock_gettime
735 (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
736 pragma Assert (Result = 0);
737 return To_Duration (TS);
738 end Monotonic_Clock;
739
740 -------------------
741 -- RT_Resolution --
742 -------------------
743
744 function RT_Resolution return Duration is
745 TS : aliased timespec;
746 Result : Interfaces.C.int;
747 begin
748 Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
749 pragma Assert (Result = 0);
750
751 return To_Duration (TS);
752 end RT_Resolution;
753
754 ------------
755 -- Wakeup --
756 ------------
757
758 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
759 pragma Unreferenced (Reason);
760 Result : Interfaces.C.int;
761 begin
762 Result := pthread_cond_signal (T.Common.LL.CV'Access);
763 pragma Assert (Result = 0);
764 end Wakeup;
765
766 -----------
767 -- Yield --
768 -----------
769
770 procedure Yield (Do_Yield : Boolean := True) is
771 Result : Interfaces.C.int;
772 pragma Unreferenced (Result);
773 begin
774 if Do_Yield then
775 Result := sched_yield;
776 end if;
777 end Yield;
778
779 ------------------
780 -- Set_Priority --
781 ------------------
782
783 procedure Set_Priority
784 (T : Task_Id;
785 Prio : System.Any_Priority;
786 Loss_Of_Inheritance : Boolean := False)
787 is
788 pragma Unreferenced (Loss_Of_Inheritance);
789
790 Result : Interfaces.C.int;
791 Param : aliased struct_sched_param;
792
793 function Get_Policy (Prio : System.Any_Priority) return Character;
794 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
795 -- Get priority specific dispatching policy
796
797 Priority_Specific_Policy : constant Character := Get_Policy (Prio);
798 -- Upper case first character of the policy name corresponding to the
799 -- task as set by a Priority_Specific_Dispatching pragma.
800
801 begin
802 T.Common.Current_Priority := Prio;
803 Param.sched_priority := To_Target_Priority (Prio);
804
805 if Time_Slice_Supported
806 and then (Dispatching_Policy = 'R'
807 or else Priority_Specific_Policy = 'R'
808 or else Time_Slice_Val > 0)
809 then
810 Result := pthread_setschedparam
811 (T.Common.LL.Thread, SCHED_RR, Param'Access);
812
813 elsif Dispatching_Policy = 'F'
814 or else Priority_Specific_Policy = 'F'
815 or else Time_Slice_Val = 0
816 then
817 Result := pthread_setschedparam
818 (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
819
820 else
821 Result := pthread_setschedparam
822 (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
823 end if;
824
825 pragma Assert (Result = 0);
826 end Set_Priority;
827
828 ------------------
829 -- Get_Priority --
830 ------------------
831
832 function Get_Priority (T : Task_Id) return System.Any_Priority is
833 begin
834 return T.Common.Current_Priority;
835 end Get_Priority;
836
837 ----------------
838 -- Enter_Task --
839 ----------------
840
841 procedure Enter_Task (Self_ID : Task_Id) is
842 begin
843 Self_ID.Common.LL.Thread := pthread_self;
844 Self_ID.Common.LL.LWP := lwp_self;
845
846 Specific.Set (Self_ID);
847
848 if Use_Alternate_Stack then
849 declare
850 Stack : aliased stack_t;
851 Result : Interfaces.C.int;
852 begin
853 Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
854 Stack.ss_size := Alternate_Stack_Size;
855 Stack.ss_flags := 0;
856 Result := sigaltstack (Stack'Access, null);
857 pragma Assert (Result = 0);
858 end;
859 end if;
860 end Enter_Task;
861
862 -------------------
863 -- Is_Valid_Task --
864 -------------------
865
866 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
867
868 -----------------------------
869 -- Register_Foreign_Thread --
870 -----------------------------
871
872 function Register_Foreign_Thread return Task_Id is
873 begin
874 if Is_Valid_Task then
875 return Self;
876 else
877 return Register_Foreign_Thread (pthread_self);
878 end if;
879 end Register_Foreign_Thread;
880
881 --------------------
882 -- Initialize_TCB --
883 --------------------
884
885 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
886 Mutex_Attr : aliased pthread_mutexattr_t;
887 Result : Interfaces.C.int;
888 Cond_Attr : aliased pthread_condattr_t;
889
890 begin
891 -- Give the task a unique serial number
892
893 Self_ID.Serial_Number := Next_Serial_Number;
894 Next_Serial_Number := Next_Serial_Number + 1;
895 pragma Assert (Next_Serial_Number /= 0);
896
897 if not Single_Lock then
898 Result := pthread_mutexattr_init (Mutex_Attr'Access);
899 pragma Assert (Result = 0 or else Result = ENOMEM);
900
901 if Result = 0 then
902 if Locking_Policy = 'C' then
903 Result :=
904 pthread_mutexattr_setprotocol
905 (Mutex_Attr'Access,
906 PTHREAD_PRIO_PROTECT);
907 pragma Assert (Result = 0);
908
909 Result :=
910 pthread_mutexattr_setprioceiling
911 (Mutex_Attr'Access,
912 Interfaces.C.int (System.Any_Priority'Last));
913 pragma Assert (Result = 0);
914
915 elsif Locking_Policy = 'I' then
916 Result :=
917 pthread_mutexattr_setprotocol
918 (Mutex_Attr'Access,
919 PTHREAD_PRIO_INHERIT);
920 pragma Assert (Result = 0);
921 end if;
922
923 Result :=
924 pthread_mutex_init
925 (Self_ID.Common.LL.L'Access,
926 Mutex_Attr'Access);
927 pragma Assert (Result = 0 or else Result = ENOMEM);
928 end if;
929
930 if Result /= 0 then
931 Succeeded := False;
932 return;
933 end if;
934
935 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
936 pragma Assert (Result = 0);
937 end if;
938
939 Result := pthread_condattr_init (Cond_Attr'Access);
940 pragma Assert (Result = 0 or else Result = ENOMEM);
941
942 if Result = 0 then
943 Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
944 pragma Assert (Result = 0);
945
946 Result :=
947 pthread_cond_init
948 (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
949 pragma Assert (Result = 0 or else Result = ENOMEM);
950 end if;
951
952 if Result = 0 then
953 Succeeded := True;
954 else
955 if not Single_Lock then
956 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
957 pragma Assert (Result = 0);
958 end if;
959
960 Succeeded := False;
961 end if;
962
963 Result := pthread_condattr_destroy (Cond_Attr'Access);
964 pragma Assert (Result = 0);
965 end Initialize_TCB;
966
967 -----------------
968 -- Create_Task --
969 -----------------
970
971 procedure Create_Task
972 (T : Task_Id;
973 Wrapper : System.Address;
974 Stack_Size : System.Parameters.Size_Type;
975 Priority : System.Any_Priority;
976 Succeeded : out Boolean)
977 is
978 Attributes : aliased pthread_attr_t;
979 Adjusted_Stack_Size : Interfaces.C.size_t;
980 Page_Size : constant Interfaces.C.size_t :=
981 Interfaces.C.size_t (Get_Page_Size);
982 Result : Interfaces.C.int;
983
984 function Thread_Body_Access is new
985 Ada.Unchecked_Conversion (System.Address, Thread_Body);
986
987 use System.Task_Info;
988
989 begin
990 Adjusted_Stack_Size :=
991 Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
992
993 if Stack_Base_Available then
994
995 -- If Stack Checking is supported then allocate 2 additional pages:
996
997 -- In the worst case, stack is allocated at something like
998 -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
999 -- to be sure the effective stack size is greater than what
1000 -- has been asked.
1001
1002 Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size;
1003 end if;
1004
1005 -- Round stack size as this is required by some OSes (Darwin)
1006
1007 Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1;
1008 Adjusted_Stack_Size :=
1009 Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size;
1010
1011 Result := pthread_attr_init (Attributes'Access);
1012 pragma Assert (Result = 0 or else Result = ENOMEM);
1013
1014 if Result /= 0 then
1015 Succeeded := False;
1016 return;
1017 end if;
1018
1019 Result :=
1020 pthread_attr_setdetachstate
1021 (Attributes'Access, PTHREAD_CREATE_DETACHED);
1022 pragma Assert (Result = 0);
1023
1024 Result :=
1025 pthread_attr_setstacksize
1026 (Attributes'Access, Adjusted_Stack_Size);
1027 pragma Assert (Result = 0);
1028
1029 if T.Common.Task_Info /= Default_Scope then
1030 case T.Common.Task_Info is
1031 when System.Task_Info.Process_Scope =>
1032 Result :=
1033 pthread_attr_setscope
1034 (Attributes'Access, PTHREAD_SCOPE_PROCESS);
1035
1036 when System.Task_Info.System_Scope =>
1037 Result :=
1038 pthread_attr_setscope
1039 (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
1040
1041 when System.Task_Info.Default_Scope =>
1042 Result := 0;
1043 end case;
1044
1045 pragma Assert (Result = 0);
1046 end if;
1047
1048 -- Since the initial signal mask of a thread is inherited from the
1049 -- creator, and the Environment task has all its signals masked, we
1050 -- do not need to manipulate caller's signal mask at this point.
1051 -- All tasks in RTS will have All_Tasks_Mask initially.
1052
1053 -- Note: the use of Unrestricted_Access in the following call is needed
1054 -- because otherwise we have an error of getting a access-to-volatile
1055 -- value which points to a non-volatile object. But in this case it is
1056 -- safe to do this, since we know we have no problems with aliasing and
1057 -- Unrestricted_Access bypasses this check.
1058
1059 Result := pthread_create
1060 (T.Common.LL.Thread'Unrestricted_Access,
1061 Attributes'Access,
1062 Thread_Body_Access (Wrapper),
1063 To_Address (T));
1064 pragma Assert (Result = 0 or else Result = EAGAIN);
1065
1066 Succeeded := Result = 0;
1067
1068 Result := pthread_attr_destroy (Attributes'Access);
1069 pragma Assert (Result = 0);
1070
1071 if Succeeded then
1072 Set_Priority (T, Priority);
1073 end if;
1074 end Create_Task;
1075
1076 ------------------
1077 -- Finalize_TCB --
1078 ------------------
1079
1080 procedure Finalize_TCB (T : Task_Id) is
1081 Result : Interfaces.C.int;
1082
1083 begin
1084 if not Single_Lock then
1085 Result := pthread_mutex_destroy (T.Common.LL.L'Access);
1086 pragma Assert (Result = 0);
1087 end if;
1088
1089 Result := pthread_cond_destroy (T.Common.LL.CV'Access);
1090 pragma Assert (Result = 0);
1091
1092 if T.Known_Tasks_Index /= -1 then
1093 Known_Tasks (T.Known_Tasks_Index) := null;
1094 end if;
1095
1096 ATCB_Allocation.Free_ATCB (T);
1097 end Finalize_TCB;
1098
1099 ---------------
1100 -- Exit_Task --
1101 ---------------
1102
1103 procedure Exit_Task is
1104 begin
1105 -- Mark this task as unknown, so that if Self is called, it won't
1106 -- return a dangling pointer.
1107
1108 Specific.Set (null);
1109 end Exit_Task;
1110
1111 ----------------
1112 -- Abort_Task --
1113 ----------------
1114
1115 procedure Abort_Task (T : Task_Id) is
1116 Result : Interfaces.C.int;
1117 begin
1118 if Abort_Handler_Installed then
1119 Result :=
1120 pthread_kill
1121 (T.Common.LL.Thread,
1122 Signal (System.Interrupt_Management.Abort_Task_Interrupt));
1123 pragma Assert (Result = 0);
1124 end if;
1125 end Abort_Task;
1126
1127 ----------------
1128 -- Initialize --
1129 ----------------
1130
1131 procedure Initialize (S : in out Suspension_Object) is
1132 Mutex_Attr : aliased pthread_mutexattr_t;
1133 Cond_Attr : aliased pthread_condattr_t;
1134 Result : Interfaces.C.int;
1135
1136 begin
1137 -- Initialize internal state (always to False (RM D.10 (6)))
1138
1139 S.State := False;
1140 S.Waiting := False;
1141
1142 -- Initialize internal mutex
1143
1144 Result := pthread_mutexattr_init (Mutex_Attr'Access);
1145 pragma Assert (Result = 0 or else Result = ENOMEM);
1146
1147 if Result = ENOMEM then
1148 raise Storage_Error;
1149 end if;
1150
1151 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
1152 pragma Assert (Result = 0 or else Result = ENOMEM);
1153
1154 if Result = ENOMEM then
1155 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1156 pragma Assert (Result = 0);
1157
1158 raise Storage_Error;
1159 end if;
1160
1161 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1162 pragma Assert (Result = 0);
1163
1164 -- Initialize internal condition variable
1165
1166 Result := pthread_condattr_init (Cond_Attr'Access);
1167 pragma Assert (Result = 0 or else Result = ENOMEM);
1168
1169 if Result /= 0 then
1170 Result := pthread_mutex_destroy (S.L'Access);
1171 pragma Assert (Result = 0);
1172
1173 -- Storage_Error is propagated as intended if the allocation of the
1174 -- underlying OS entities fails.
1175
1176 raise Storage_Error;
1177
1178 else
1179 Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
1180 pragma Assert (Result = 0);
1181 end if;
1182
1183 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1184 pragma Assert (Result = 0 or else Result = ENOMEM);
1185
1186 if Result /= 0 then
1187 Result := pthread_mutex_destroy (S.L'Access);
1188 pragma Assert (Result = 0);
1189
1190 Result := pthread_condattr_destroy (Cond_Attr'Access);
1191 pragma Assert (Result = 0);
1192
1193 -- Storage_Error is propagated as intended if the allocation of the
1194 -- underlying OS entities fails.
1195
1196 raise Storage_Error;
1197 end if;
1198
1199 Result := pthread_condattr_destroy (Cond_Attr'Access);
1200 pragma Assert (Result = 0);
1201 end Initialize;
1202
1203 --------------
1204 -- Finalize --
1205 --------------
1206
1207 procedure Finalize (S : in out Suspension_Object) is
1208 Result : Interfaces.C.int;
1209
1210 begin
1211 -- Destroy internal mutex
1212
1213 Result := pthread_mutex_destroy (S.L'Access);
1214 pragma Assert (Result = 0);
1215
1216 -- Destroy internal condition variable
1217
1218 Result := pthread_cond_destroy (S.CV'Access);
1219 pragma Assert (Result = 0);
1220 end Finalize;
1221
1222 -------------------
1223 -- Current_State --
1224 -------------------
1225
1226 function Current_State (S : Suspension_Object) return Boolean is
1227 begin
1228 -- We do not want to use lock on this read operation. State is marked
1229 -- as Atomic so that we ensure that the value retrieved is correct.
1230
1231 return S.State;
1232 end Current_State;
1233
1234 ---------------
1235 -- Set_False --
1236 ---------------
1237
1238 procedure Set_False (S : in out Suspension_Object) is
1239 Result : Interfaces.C.int;
1240
1241 begin
1242 SSL.Abort_Defer.all;
1243
1244 Result := pthread_mutex_lock (S.L'Access);
1245 pragma Assert (Result = 0);
1246
1247 S.State := False;
1248
1249 Result := pthread_mutex_unlock (S.L'Access);
1250 pragma Assert (Result = 0);
1251
1252 SSL.Abort_Undefer.all;
1253 end Set_False;
1254
1255 --------------
1256 -- Set_True --
1257 --------------
1258
1259 procedure Set_True (S : in out Suspension_Object) is
1260 Result : Interfaces.C.int;
1261
1262 begin
1263 SSL.Abort_Defer.all;
1264
1265 Result := pthread_mutex_lock (S.L'Access);
1266 pragma Assert (Result = 0);
1267
1268 -- If there is already a task waiting on this suspension object then
1269 -- we resume it, leaving the state of the suspension object to False,
1270 -- as it is specified in (RM D.10(9)). Otherwise, it just leaves
1271 -- the state to True.
1272
1273 if S.Waiting then
1274 S.Waiting := False;
1275 S.State := False;
1276
1277 Result := pthread_cond_signal (S.CV'Access);
1278 pragma Assert (Result = 0);
1279
1280 else
1281 S.State := True;
1282 end if;
1283
1284 Result := pthread_mutex_unlock (S.L'Access);
1285 pragma Assert (Result = 0);
1286
1287 SSL.Abort_Undefer.all;
1288 end Set_True;
1289
1290 ------------------------
1291 -- Suspend_Until_True --
1292 ------------------------
1293
1294 procedure Suspend_Until_True (S : in out Suspension_Object) is
1295 Result : Interfaces.C.int;
1296
1297 begin
1298 SSL.Abort_Defer.all;
1299
1300 Result := pthread_mutex_lock (S.L'Access);
1301 pragma Assert (Result = 0);
1302
1303 if S.Waiting then
1304
1305 -- Program_Error must be raised upon calling Suspend_Until_True
1306 -- if another task is already waiting on that suspension object
1307 -- (RM D.10(10)).
1308
1309 Result := pthread_mutex_unlock (S.L'Access);
1310 pragma Assert (Result = 0);
1311
1312 SSL.Abort_Undefer.all;
1313
1314 raise Program_Error;
1315
1316 else
1317 -- Suspend the task if the state is False. Otherwise, the task
1318 -- continues its execution, and the state of the suspension object
1319 -- is set to False (ARM D.10 par. 9).
1320
1321 if S.State then
1322 S.State := False;
1323 else
1324 S.Waiting := True;
1325
1326 loop
1327 -- Loop in case pthread_cond_wait returns earlier than expected
1328 -- (e.g. in case of EINTR caused by a signal).
1329
1330 Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1331 pragma Assert (Result = 0 or else Result = EINTR);
1332
1333 exit when not S.Waiting;
1334 end loop;
1335 end if;
1336
1337 Result := pthread_mutex_unlock (S.L'Access);
1338 pragma Assert (Result = 0);
1339
1340 SSL.Abort_Undefer.all;
1341 end if;
1342 end Suspend_Until_True;
1343
1344 ----------------
1345 -- Check_Exit --
1346 ----------------
1347
1348 -- Dummy version
1349
1350 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1351 pragma Unreferenced (Self_ID);
1352 begin
1353 return True;
1354 end Check_Exit;
1355
1356 --------------------
1357 -- Check_No_Locks --
1358 --------------------
1359
1360 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1361 pragma Unreferenced (Self_ID);
1362 begin
1363 return True;
1364 end Check_No_Locks;
1365
1366 ----------------------
1367 -- Environment_Task --
1368 ----------------------
1369
1370 function Environment_Task return Task_Id is
1371 begin
1372 return Environment_Task_Id;
1373 end Environment_Task;
1374
1375 --------------
1376 -- Lock_RTS --
1377 --------------
1378
1379 procedure Lock_RTS is
1380 begin
1381 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1382 end Lock_RTS;
1383
1384 ----------------
1385 -- Unlock_RTS --
1386 ----------------
1387
1388 procedure Unlock_RTS is
1389 begin
1390 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1391 end Unlock_RTS;
1392
1393 ------------------
1394 -- Suspend_Task --
1395 ------------------
1396
1397 function Suspend_Task
1398 (T : ST.Task_Id;
1399 Thread_Self : Thread_Id) return Boolean
1400 is
1401 pragma Unreferenced (T, Thread_Self);
1402 begin
1403 return False;
1404 end Suspend_Task;
1405
1406 -----------------
1407 -- Resume_Task --
1408 -----------------
1409
1410 function Resume_Task
1411 (T : ST.Task_Id;
1412 Thread_Self : Thread_Id) return Boolean
1413 is
1414 pragma Unreferenced (T, Thread_Self);
1415 begin
1416 return False;
1417 end Resume_Task;
1418
1419 --------------------
1420 -- Stop_All_Tasks --
1421 --------------------
1422
1423 procedure Stop_All_Tasks is
1424 begin
1425 null;
1426 end Stop_All_Tasks;
1427
1428 ---------------
1429 -- Stop_Task --
1430 ---------------
1431
1432 function Stop_Task (T : ST.Task_Id) return Boolean is
1433 pragma Unreferenced (T);
1434 begin
1435 return False;
1436 end Stop_Task;
1437
1438 -------------------
1439 -- Continue_Task --
1440 -------------------
1441
1442 function Continue_Task (T : ST.Task_Id) return Boolean is
1443 pragma Unreferenced (T);
1444 begin
1445 return False;
1446 end Continue_Task;
1447
1448 ----------------
1449 -- Initialize --
1450 ----------------
1451
1452 procedure Initialize (Environment_Task : Task_Id) is
1453 act : aliased struct_sigaction;
1454 old_act : aliased struct_sigaction;
1455 Tmp_Set : aliased sigset_t;
1456 Result : Interfaces.C.int;
1457
1458 function State
1459 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1460 pragma Import (C, State, "__gnat_get_interrupt_state");
1461 -- Get interrupt state. Defined in a-init.c
1462 -- The input argument is the interrupt number,
1463 -- and the result is one of the following:
1464
1465 Default : constant Character := 's';
1466 -- 'n' this interrupt not set by any Interrupt_State pragma
1467 -- 'u' Interrupt_State pragma set state to User
1468 -- 'r' Interrupt_State pragma set state to Runtime
1469 -- 's' Interrupt_State pragma set state to System (use "default"
1470 -- system handler)
1471
1472 begin
1473 Environment_Task_Id := Environment_Task;
1474
1475 Interrupt_Management.Initialize;
1476
1477 -- Prepare the set of signals that should unblocked in all tasks
1478
1479 Result := sigemptyset (Unblocked_Signal_Mask'Access);
1480 pragma Assert (Result = 0);
1481
1482 for J in Interrupt_Management.Interrupt_ID loop
1483 if System.Interrupt_Management.Keep_Unmasked (J) then
1484 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1485 pragma Assert (Result = 0);
1486 end if;
1487 end loop;
1488
1489 -- Initialize the lock used to synchronize chain of all ATCBs
1490
1491 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1492
1493 Specific.Initialize (Environment_Task);
1494
1495 if Use_Alternate_Stack then
1496 Environment_Task.Common.Task_Alternate_Stack :=
1497 Alternate_Stack'Address;
1498 end if;
1499
1500 -- Make environment task known here because it doesn't go through
1501 -- Activate_Tasks, which does it for all other tasks.
1502
1503 Known_Tasks (Known_Tasks'First) := Environment_Task;
1504 Environment_Task.Known_Tasks_Index := Known_Tasks'First;
1505
1506 Enter_Task (Environment_Task);
1507
1508 if State
1509 (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
1510 then
1511 act.sa_flags := 0;
1512 act.sa_handler := Abort_Handler'Address;
1513
1514 Result := sigemptyset (Tmp_Set'Access);
1515 pragma Assert (Result = 0);
1516 act.sa_mask := Tmp_Set;
1517
1518 Result :=
1519 sigaction
1520 (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1521 act'Unchecked_Access,
1522 old_act'Unchecked_Access);
1523 pragma Assert (Result = 0);
1524 Abort_Handler_Installed := True;
1525 end if;
1526 end Initialize;
1527
1528 -----------------------
1529 -- Set_Task_Affinity --
1530 -----------------------
1531
1532 procedure Set_Task_Affinity (T : ST.Task_Id) is
1533 pragma Unreferenced (T);
1534
1535 begin
1536 -- Setting task affinity is not supported by the underlying system
1537
1538 null;
1539 end Set_Task_Affinity;
1540
1541 end System.Task_Primitives.Operations;