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