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-2014, 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 := 297 OS_Primitives.Monotonic_Clock; 298 RT_Time : constant Duration := 299 Time + Check_Time - Cal_Check_Time; 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 Guard_Page_Address : Address; 319 320 Res : Interfaces.C.int; 321 322 begin 323 if Stack_Base_Available then 324 325 -- Compute the guard page address 326 327 Guard_Page_Address := 328 Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; 329 330 Res := 331 mprotect (Guard_Page_Address, Get_Page_Size, 332 prot => (if On then PROT_ON else PROT_OFF)); 333 pragma Assert (Res = 0); 334 end if; 335 end Stack_Guard; 336 337 -------------------- 338 -- Get_Thread_Id -- 339 -------------------- 340 341 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is 342 begin 343 return T.Common.LL.Thread; 344 end Get_Thread_Id; 345 346 ---------- 347 -- Self -- 348 ---------- 349 350 function Self return Task_Id renames Specific.Self; 351 352 --------------------- 353 -- Initialize_Lock -- 354 --------------------- 355 356 -- Note: mutexes and cond_variables needed per-task basis are 357 -- initialized in Initialize_TCB and the Storage_Error is 358 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) 359 -- used in RTS is initialized before any status change of RTS. 360 -- Therefore raising Storage_Error in the following routines 361 -- should be able to be handled safely. 362 363 procedure Initialize_Lock 364 (Prio : System.Any_Priority; 365 L : not null access Lock) 366 is 367 Attributes : aliased pthread_mutexattr_t; 368 Result : Interfaces.C.int; 369 370 begin 371 Result := pthread_mutexattr_init (Attributes'Access); 372 pragma Assert (Result = 0 or else Result = ENOMEM); 373 374 if Result = ENOMEM then 375 raise Storage_Error; 376 end if; 377 378 if Locking_Policy = 'C' then 379 Result := pthread_mutexattr_setprotocol 380 (Attributes'Access, PTHREAD_PRIO_PROTECT); 381 pragma Assert (Result = 0); 382 383 Result := pthread_mutexattr_setprioceiling 384 (Attributes'Access, Interfaces.C.int (Prio)); 385 pragma Assert (Result = 0); 386 387 elsif Locking_Policy = 'I' then 388 Result := pthread_mutexattr_setprotocol 389 (Attributes'Access, PTHREAD_PRIO_INHERIT); 390 pragma Assert (Result = 0); 391 end if; 392 393 Result := pthread_mutex_init (L.WO'Access, Attributes'Access); 394 pragma Assert (Result = 0 or else Result = ENOMEM); 395 396 if Result = ENOMEM then 397 Result := pthread_mutexattr_destroy (Attributes'Access); 398 raise Storage_Error; 399 end if; 400 401 Result := pthread_mutexattr_destroy (Attributes'Access); 402 pragma Assert (Result = 0); 403 end Initialize_Lock; 404 405 procedure Initialize_Lock 406 (L : not null access RTS_Lock; Level : Lock_Level) 407 is 408 pragma Unreferenced (Level); 409 410 Attributes : aliased pthread_mutexattr_t; 411 Result : Interfaces.C.int; 412 413 begin 414 Result := pthread_mutexattr_init (Attributes'Access); 415 pragma Assert (Result = 0 or else Result = ENOMEM); 416 417 if Result = ENOMEM then 418 raise Storage_Error; 419 end if; 420 421 if Locking_Policy = 'C' then 422 Result := pthread_mutexattr_setprotocol 423 (Attributes'Access, PTHREAD_PRIO_PROTECT); 424 pragma Assert (Result = 0); 425 426 Result := pthread_mutexattr_setprioceiling 427 (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); 428 pragma Assert (Result = 0); 429 430 elsif Locking_Policy = 'I' then 431 Result := pthread_mutexattr_setprotocol 432 (Attributes'Access, PTHREAD_PRIO_INHERIT); 433 pragma Assert (Result = 0); 434 end if; 435 436 Result := pthread_mutex_init (L, Attributes'Access); 437 pragma Assert (Result = 0 or else Result = ENOMEM); 438 439 if Result = ENOMEM then 440 Result := pthread_mutexattr_destroy (Attributes'Access); 441 raise Storage_Error; 442 end if; 443 444 Result := pthread_mutexattr_destroy (Attributes'Access); 445 pragma Assert (Result = 0); 446 end Initialize_Lock; 447 448 ------------------- 449 -- Finalize_Lock -- 450 ------------------- 451 452 procedure Finalize_Lock (L : not null access Lock) is 453 Result : Interfaces.C.int; 454 begin 455 Result := pthread_mutex_destroy (L.WO'Access); 456 pragma Assert (Result = 0); 457 end Finalize_Lock; 458 459 procedure Finalize_Lock (L : not null access RTS_Lock) is 460 Result : Interfaces.C.int; 461 begin 462 Result := pthread_mutex_destroy (L); 463 pragma Assert (Result = 0); 464 end Finalize_Lock; 465 466 ---------------- 467 -- Write_Lock -- 468 ---------------- 469 470 procedure Write_Lock 471 (L : not null access Lock; Ceiling_Violation : out Boolean) 472 is 473 Result : Interfaces.C.int; 474 475 begin 476 Result := pthread_mutex_lock (L.WO'Access); 477 478 -- Assume that the cause of EINVAL is a priority ceiling violation 479 480 Ceiling_Violation := (Result = EINVAL); 481 pragma Assert (Result = 0 or else Result = EINVAL); 482 end Write_Lock; 483 484 procedure Write_Lock 485 (L : not null access RTS_Lock; 486 Global_Lock : Boolean := False) 487 is 488 Result : Interfaces.C.int; 489 begin 490 if not Single_Lock or else Global_Lock then 491 Result := pthread_mutex_lock (L); 492 pragma Assert (Result = 0); 493 end if; 494 end Write_Lock; 495 496 procedure Write_Lock (T : Task_Id) is 497 Result : Interfaces.C.int; 498 begin 499 if not Single_Lock then 500 Result := pthread_mutex_lock (T.Common.LL.L'Access); 501 pragma Assert (Result = 0); 502 end if; 503 end Write_Lock; 504 505 --------------- 506 -- Read_Lock -- 507 --------------- 508 509 procedure Read_Lock 510 (L : not null access Lock; Ceiling_Violation : out Boolean) is 511 begin 512 Write_Lock (L, Ceiling_Violation); 513 end Read_Lock; 514 515 ------------ 516 -- Unlock -- 517 ------------ 518 519 procedure Unlock (L : not null access Lock) is 520 Result : Interfaces.C.int; 521 begin 522 Result := pthread_mutex_unlock (L.WO'Access); 523 pragma Assert (Result = 0); 524 end Unlock; 525 526 procedure Unlock 527 (L : not null access RTS_Lock; Global_Lock : Boolean := False) 528 is 529 Result : Interfaces.C.int; 530 begin 531 if not Single_Lock or else Global_Lock then 532 Result := pthread_mutex_unlock (L); 533 pragma Assert (Result = 0); 534 end if; 535 end Unlock; 536 537 procedure Unlock (T : Task_Id) is 538 Result : Interfaces.C.int; 539 begin 540 if not Single_Lock then 541 Result := pthread_mutex_unlock (T.Common.LL.L'Access); 542 pragma Assert (Result = 0); 543 end if; 544 end Unlock; 545 546 ----------------- 547 -- Set_Ceiling -- 548 ----------------- 549 550 -- Dynamic priority ceilings are not supported by the underlying system 551 552 procedure Set_Ceiling 553 (L : not null access Lock; 554 Prio : System.Any_Priority) 555 is 556 pragma Unreferenced (L, Prio); 557 begin 558 null; 559 end Set_Ceiling; 560 561 ----------- 562 -- Sleep -- 563 ----------- 564 565 procedure Sleep 566 (Self_ID : Task_Id; 567 Reason : System.Tasking.Task_States) 568 is 569 pragma Unreferenced (Reason); 570 571 Result : Interfaces.C.int; 572 573 begin 574 Result := 575 pthread_cond_wait 576 (cond => Self_ID.Common.LL.CV'Access, 577 mutex => (if Single_Lock 578 then Single_RTS_Lock'Access 579 else Self_ID.Common.LL.L'Access)); 580 581 -- EINTR is not considered a failure 582 583 pragma Assert (Result = 0 or else Result = EINTR); 584 end Sleep; 585 586 ----------------- 587 -- Timed_Sleep -- 588 ----------------- 589 590 -- This is for use within the run-time system, so abort is 591 -- assumed to be already deferred, and the caller should be 592 -- holding its own ATCB lock. 593 594 procedure Timed_Sleep 595 (Self_ID : Task_Id; 596 Time : Duration; 597 Mode : ST.Delay_Modes; 598 Reason : Task_States; 599 Timedout : out Boolean; 600 Yielded : out Boolean) 601 is 602 pragma Unreferenced (Reason); 603 604 Base_Time : Duration; 605 Check_Time : Duration; 606 Abs_Time : Duration; 607 Rel_Time : Duration; 608 609 Request : aliased timespec; 610 Result : Interfaces.C.int; 611 612 begin 613 Timedout := True; 614 Yielded := False; 615 616 Compute_Deadline 617 (Time => Time, 618 Mode => Mode, 619 Check_Time => Check_Time, 620 Abs_Time => Abs_Time, 621 Rel_Time => Rel_Time); 622 Base_Time := Check_Time; 623 624 if Abs_Time > Check_Time then 625 Request := 626 To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); 627 628 loop 629 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 630 631 Result := 632 pthread_cond_timedwait 633 (cond => Self_ID.Common.LL.CV'Access, 634 mutex => (if Single_Lock 635 then Single_RTS_Lock'Access 636 else Self_ID.Common.LL.L'Access), 637 abstime => Request'Access); 638 639 Check_Time := Monotonic_Clock; 640 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; 641 642 if Result = 0 or Result = EINTR then 643 644 -- Somebody may have called Wakeup for us 645 646 Timedout := False; 647 exit; 648 end if; 649 650 pragma Assert (Result = ETIMEDOUT); 651 end loop; 652 end if; 653 end Timed_Sleep; 654 655 ----------------- 656 -- Timed_Delay -- 657 ----------------- 658 659 -- This is for use in implementing delay statements, so we assume the 660 -- caller is abort-deferred but is holding no locks. 661 662 procedure Timed_Delay 663 (Self_ID : Task_Id; 664 Time : Duration; 665 Mode : ST.Delay_Modes) 666 is 667 Base_Time : Duration; 668 Check_Time : Duration; 669 Abs_Time : Duration; 670 Rel_Time : Duration; 671 Request : aliased timespec; 672 673 Result : Interfaces.C.int; 674 pragma Warnings (Off, Result); 675 676 begin 677 if Single_Lock then 678 Lock_RTS; 679 end if; 680 681 Write_Lock (Self_ID); 682 683 Compute_Deadline 684 (Time => Time, 685 Mode => Mode, 686 Check_Time => Check_Time, 687 Abs_Time => Abs_Time, 688 Rel_Time => Rel_Time); 689 Base_Time := Check_Time; 690 691 if Abs_Time > Check_Time then 692 Request := 693 To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); 694 Self_ID.Common.State := Delay_Sleep; 695 696 loop 697 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 698 699 Result := 700 pthread_cond_timedwait 701 (cond => Self_ID.Common.LL.CV'Access, 702 mutex => (if Single_Lock 703 then Single_RTS_Lock'Access 704 else Self_ID.Common.LL.L'Access), 705 abstime => Request'Access); 706 707 Check_Time := Monotonic_Clock; 708 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; 709 710 pragma Assert (Result = 0 711 or else Result = ETIMEDOUT 712 or else Result = EINTR); 713 end loop; 714 715 Self_ID.Common.State := Runnable; 716 end if; 717 718 Unlock (Self_ID); 719 720 if Single_Lock then 721 Unlock_RTS; 722 end if; 723 724 Result := sched_yield; 725 end Timed_Delay; 726 727 --------------------- 728 -- Monotonic_Clock -- 729 --------------------- 730 731 function Monotonic_Clock return Duration is 732 TS : aliased timespec; 733 Result : Interfaces.C.int; 734 begin 735 Result := clock_gettime 736 (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access); 737 pragma Assert (Result = 0); 738 return To_Duration (TS); 739 end Monotonic_Clock; 740 741 ------------------- 742 -- RT_Resolution -- 743 ------------------- 744 745 function RT_Resolution return Duration is 746 TS : aliased timespec; 747 Result : Interfaces.C.int; 748 begin 749 Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); 750 pragma Assert (Result = 0); 751 752 return To_Duration (TS); 753 end RT_Resolution; 754 755 ------------ 756 -- Wakeup -- 757 ------------ 758 759 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is 760 pragma Unreferenced (Reason); 761 Result : Interfaces.C.int; 762 begin 763 Result := pthread_cond_signal (T.Common.LL.CV'Access); 764 pragma Assert (Result = 0); 765 end Wakeup; 766 767 ----------- 768 -- Yield -- 769 ----------- 770 771 procedure Yield (Do_Yield : Boolean := True) is 772 Result : Interfaces.C.int; 773 pragma Unreferenced (Result); 774 begin 775 if Do_Yield then 776 Result := sched_yield; 777 end if; 778 end Yield; 779 780 ------------------ 781 -- Set_Priority -- 782 ------------------ 783 784 procedure Set_Priority 785 (T : Task_Id; 786 Prio : System.Any_Priority; 787 Loss_Of_Inheritance : Boolean := False) 788 is 789 pragma Unreferenced (Loss_Of_Inheritance); 790 791 Result : Interfaces.C.int; 792 Param : aliased struct_sched_param; 793 794 function Get_Policy (Prio : System.Any_Priority) return Character; 795 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); 796 -- Get priority specific dispatching policy 797 798 Priority_Specific_Policy : constant Character := Get_Policy (Prio); 799 -- Upper case first character of the policy name corresponding to the 800 -- task as set by a Priority_Specific_Dispatching pragma. 801 802 begin 803 T.Common.Current_Priority := Prio; 804 Param.sched_priority := To_Target_Priority (Prio); 805 806 if Time_Slice_Supported 807 and then (Dispatching_Policy = 'R' 808 or else Priority_Specific_Policy = 'R' 809 or else Time_Slice_Val > 0) 810 then 811 Result := pthread_setschedparam 812 (T.Common.LL.Thread, SCHED_RR, Param'Access); 813 814 elsif Dispatching_Policy = 'F' 815 or else Priority_Specific_Policy = 'F' 816 or else Time_Slice_Val = 0 817 then 818 Result := pthread_setschedparam 819 (T.Common.LL.Thread, SCHED_FIFO, Param'Access); 820 821 else 822 Result := pthread_setschedparam 823 (T.Common.LL.Thread, SCHED_OTHER, Param'Access); 824 end if; 825 826 pragma Assert (Result = 0); 827 end Set_Priority; 828 829 ------------------ 830 -- Get_Priority -- 831 ------------------ 832 833 function Get_Priority (T : Task_Id) return System.Any_Priority is 834 begin 835 return T.Common.Current_Priority; 836 end Get_Priority; 837 838 ---------------- 839 -- Enter_Task -- 840 ---------------- 841 842 procedure Enter_Task (Self_ID : Task_Id) is 843 begin 844 Self_ID.Common.LL.Thread := pthread_self; 845 Self_ID.Common.LL.LWP := lwp_self; 846 847 Specific.Set (Self_ID); 848 849 if Use_Alternate_Stack then 850 declare 851 Stack : aliased stack_t; 852 Result : Interfaces.C.int; 853 begin 854 Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; 855 Stack.ss_size := Alternate_Stack_Size; 856 Stack.ss_flags := 0; 857 Result := sigaltstack (Stack'Access, null); 858 pragma Assert (Result = 0); 859 end; 860 end if; 861 end Enter_Task; 862 863 ------------------- 864 -- Is_Valid_Task -- 865 ------------------- 866 867 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 868 869 ----------------------------- 870 -- Register_Foreign_Thread -- 871 ----------------------------- 872 873 function Register_Foreign_Thread return Task_Id is 874 begin 875 if Is_Valid_Task then 876 return Self; 877 else 878 return Register_Foreign_Thread (pthread_self); 879 end if; 880 end Register_Foreign_Thread; 881 882 -------------------- 883 -- Initialize_TCB -- 884 -------------------- 885 886 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is 887 Mutex_Attr : aliased pthread_mutexattr_t; 888 Result : Interfaces.C.int; 889 Cond_Attr : aliased pthread_condattr_t; 890 891 begin 892 -- Give the task a unique serial number 893 894 Self_ID.Serial_Number := Next_Serial_Number; 895 Next_Serial_Number := Next_Serial_Number + 1; 896 pragma Assert (Next_Serial_Number /= 0); 897 898 if not Single_Lock then 899 Result := pthread_mutexattr_init (Mutex_Attr'Access); 900 pragma Assert (Result = 0 or else Result = ENOMEM); 901 902 if Result = 0 then 903 if Locking_Policy = 'C' then 904 Result := 905 pthread_mutexattr_setprotocol 906 (Mutex_Attr'Access, 907 PTHREAD_PRIO_PROTECT); 908 pragma Assert (Result = 0); 909 910 Result := 911 pthread_mutexattr_setprioceiling 912 (Mutex_Attr'Access, 913 Interfaces.C.int (System.Any_Priority'Last)); 914 pragma Assert (Result = 0); 915 916 elsif Locking_Policy = 'I' then 917 Result := 918 pthread_mutexattr_setprotocol 919 (Mutex_Attr'Access, 920 PTHREAD_PRIO_INHERIT); 921 pragma Assert (Result = 0); 922 end if; 923 924 Result := 925 pthread_mutex_init 926 (Self_ID.Common.LL.L'Access, 927 Mutex_Attr'Access); 928 pragma Assert (Result = 0 or else Result = ENOMEM); 929 end if; 930 931 if Result /= 0 then 932 Succeeded := False; 933 return; 934 end if; 935 936 Result := pthread_mutexattr_destroy (Mutex_Attr'Access); 937 pragma Assert (Result = 0); 938 end if; 939 940 Result := pthread_condattr_init (Cond_Attr'Access); 941 pragma Assert (Result = 0 or else Result = ENOMEM); 942 943 if Result = 0 then 944 Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); 945 pragma Assert (Result = 0); 946 947 Result := 948 pthread_cond_init 949 (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); 950 pragma Assert (Result = 0 or else Result = ENOMEM); 951 end if; 952 953 if Result = 0 then 954 Succeeded := True; 955 else 956 if not Single_Lock then 957 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); 958 pragma Assert (Result = 0); 959 end if; 960 961 Succeeded := False; 962 end if; 963 964 Result := pthread_condattr_destroy (Cond_Attr'Access); 965 pragma Assert (Result = 0); 966 end Initialize_TCB; 967 968 ----------------- 969 -- Create_Task -- 970 ----------------- 971 972 procedure Create_Task 973 (T : Task_Id; 974 Wrapper : System.Address; 975 Stack_Size : System.Parameters.Size_Type; 976 Priority : System.Any_Priority; 977 Succeeded : out Boolean) 978 is 979 Attributes : aliased pthread_attr_t; 980 Adjusted_Stack_Size : Interfaces.C.size_t; 981 Page_Size : constant 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