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