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