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