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