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