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