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-2012, 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 type timeval is array (1 .. 2) of C.long; 631 632 procedure timeval_to_duration 633 (T : not null access timeval; 634 sec : not null access C.long; 635 usec : not null access C.long); 636 pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); 637 638 Micro : constant := 10**6; 639 sec : aliased C.long; 640 usec : aliased C.long; 641 TV : aliased timeval; 642 Result : int; 643 644 function gettimeofday 645 (Tv : access timeval; 646 Tz : System.Address := System.Null_Address) return int; 647 pragma Import (C, gettimeofday, "gettimeofday"); 648 649 begin 650 Result := gettimeofday (TV'Access, System.Null_Address); 651 pragma Assert (Result = 0); 652 timeval_to_duration (TV'Access, sec'Access, usec'Access); 653 return Duration (sec) + Duration (usec) / Micro; 654 end Monotonic_Clock; 655 656 ------------------- 657 -- RT_Resolution -- 658 ------------------- 659 660 function RT_Resolution return Duration is 661 begin 662 return 10#1.0#E-6; 663 end RT_Resolution; 664 665 ------------ 666 -- Wakeup -- 667 ------------ 668 669 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is 670 pragma Unreferenced (Reason); 671 Result : Interfaces.C.int; 672 begin 673 Result := pthread_cond_signal (T.Common.LL.CV'Access); 674 pragma Assert (Result = 0); 675 end Wakeup; 676 677 ----------- 678 -- Yield -- 679 ----------- 680 681 procedure Yield (Do_Yield : Boolean := True) is 682 Result : Interfaces.C.int; 683 pragma Unreferenced (Result); 684 begin 685 if Do_Yield then 686 Result := sched_yield; 687 end if; 688 end Yield; 689 690 ------------------ 691 -- Set_Priority -- 692 ------------------ 693 694 procedure Set_Priority 695 (T : Task_Id; 696 Prio : System.Any_Priority; 697 Loss_Of_Inheritance : Boolean := False) 698 is 699 pragma Unreferenced (Loss_Of_Inheritance); 700 701 Result : Interfaces.C.int; 702 Param : aliased struct_sched_param; 703 704 function Get_Policy (Prio : System.Any_Priority) return Character; 705 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); 706 -- Get priority specific dispatching policy 707 708 Priority_Specific_Policy : constant Character := Get_Policy (Prio); 709 -- Upper case first character of the policy name corresponding to the 710 -- task as set by a Priority_Specific_Dispatching pragma. 711 712 begin 713 T.Common.Current_Priority := Prio; 714 715 -- Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99 716 717 Param.sched_priority := Interfaces.C.int (Prio) + 1; 718 719 if Dispatching_Policy = 'R' 720 or else Priority_Specific_Policy = 'R' 721 or else Time_Slice_Val > 0 722 then 723 Result := 724 pthread_setschedparam 725 (T.Common.LL.Thread, SCHED_RR, Param'Access); 726 727 elsif Dispatching_Policy = 'F' 728 or else Priority_Specific_Policy = 'F' 729 or else Time_Slice_Val = 0 730 then 731 Result := 732 pthread_setschedparam 733 (T.Common.LL.Thread, SCHED_FIFO, Param'Access); 734 735 else 736 Param.sched_priority := 0; 737 Result := 738 pthread_setschedparam 739 (T.Common.LL.Thread, 740 SCHED_OTHER, Param'Access); 741 end if; 742 743 pragma Assert (Result = 0 or else Result = EPERM); 744 end Set_Priority; 745 746 ------------------ 747 -- Get_Priority -- 748 ------------------ 749 750 function Get_Priority (T : Task_Id) return System.Any_Priority is 751 begin 752 return T.Common.Current_Priority; 753 end Get_Priority; 754 755 ---------------- 756 -- Enter_Task -- 757 ---------------- 758 759 procedure Enter_Task (Self_ID : Task_Id) is 760 begin 761 if Self_ID.Common.Task_Info /= null 762 and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU 763 then 764 raise Invalid_CPU_Number; 765 end if; 766 767 Self_ID.Common.LL.Thread := pthread_self; 768 Self_ID.Common.LL.LWP := lwp_self; 769 770 if Self_ID.Common.Task_Image_Len > 0 then 771 declare 772 Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1); 773 Result : int; 774 775 begin 776 -- Set thread name to ease debugging 777 778 Task_Name (1 .. Self_ID.Common.Task_Image_Len) := 779 Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len); 780 Task_Name (Self_ID.Common.Task_Image_Len + 1) := ASCII.NUL; 781 782 Result := prctl (PR_SET_NAME, unsigned_long (Task_Name'Address)); 783 pragma Assert (Result = 0); 784 end; 785 end if; 786 787 Specific.Set (Self_ID); 788 789 if Use_Alternate_Stack 790 and then Self_ID.Common.Task_Alternate_Stack /= Null_Address 791 then 792 declare 793 Stack : aliased stack_t; 794 Result : Interfaces.C.int; 795 begin 796 Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; 797 Stack.ss_size := Alternate_Stack_Size; 798 Stack.ss_flags := 0; 799 Result := sigaltstack (Stack'Access, null); 800 pragma Assert (Result = 0); 801 end; 802 end if; 803 end Enter_Task; 804 805 ------------------- 806 -- Is_Valid_Task -- 807 ------------------- 808 809 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 810 811 ----------------------------- 812 -- Register_Foreign_Thread -- 813 ----------------------------- 814 815 function Register_Foreign_Thread return Task_Id is 816 begin 817 if Is_Valid_Task then 818 return Self; 819 else 820 return Register_Foreign_Thread (pthread_self); 821 end if; 822 end Register_Foreign_Thread; 823 824 -------------------- 825 -- Initialize_TCB -- 826 -------------------- 827 828 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is 829 Cond_Attr : aliased pthread_condattr_t; 830 Result : Interfaces.C.int; 831 832 begin 833 -- Give the task a unique serial number 834 835 Self_ID.Serial_Number := Next_Serial_Number; 836 Next_Serial_Number := Next_Serial_Number + 1; 837 pragma Assert (Next_Serial_Number /= 0); 838 839 Self_ID.Common.LL.Thread := Null_Thread_Id; 840 841 if not Single_Lock then 842 Result := 843 pthread_mutex_init (Self_ID.Common.LL.L'Access, null); 844 pragma Assert (Result = 0 or else Result = ENOMEM); 845 846 if Result /= 0 then 847 Succeeded := False; 848 return; 849 end if; 850 end if; 851 852 Result := pthread_condattr_init (Cond_Attr'Access); 853 pragma Assert (Result = 0); 854 855 Result := 856 pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); 857 pragma Assert (Result = 0 or else Result = ENOMEM); 858 859 if Result = 0 then 860 Succeeded := True; 861 else 862 if not Single_Lock then 863 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); 864 pragma Assert (Result = 0); 865 end if; 866 867 Succeeded := False; 868 end if; 869 end Initialize_TCB; 870 871 ----------------- 872 -- Create_Task -- 873 ----------------- 874 875 procedure Create_Task 876 (T : Task_Id; 877 Wrapper : System.Address; 878 Stack_Size : System.Parameters.Size_Type; 879 Priority : System.Any_Priority; 880 Succeeded : out Boolean) 881 is 882 Attributes : aliased pthread_attr_t; 883 Adjusted_Stack_Size : Interfaces.C.size_t; 884 Result : Interfaces.C.int; 885 886 use type System.Multiprocessors.CPU_Range; 887 888 begin 889 -- Check whether both Dispatching_Domain and CPU are specified for 890 -- the task, and the CPU value is not contained within the range of 891 -- processors for the domain. 892 893 if T.Common.Domain /= null 894 and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU 895 and then 896 (T.Common.Base_CPU not in T.Common.Domain'Range 897 or else not T.Common.Domain (T.Common.Base_CPU)) 898 then 899 Succeeded := False; 900 return; 901 end if; 902 903 Adjusted_Stack_Size := 904 Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); 905 906 Result := pthread_attr_init (Attributes'Access); 907 pragma Assert (Result = 0 or else Result = ENOMEM); 908 909 if Result /= 0 then 910 Succeeded := False; 911 return; 912 end if; 913 914 Result := 915 pthread_attr_setstacksize (Attributes'Access, Adjusted_Stack_Size); 916 pragma Assert (Result = 0); 917 918 Result := 919 pthread_attr_setdetachstate 920 (Attributes'Access, PTHREAD_CREATE_DETACHED); 921 pragma Assert (Result = 0); 922 923 -- Set the required attributes for the creation of the thread 924 925 -- Note: Previously, we called pthread_setaffinity_np (after thread 926 -- creation but before thread activation) to set the affinity but it was 927 -- not behaving as expected. Setting the required attributes for the 928 -- creation of the thread works correctly and it is more appropriate. 929 930 -- Do nothing if required support not provided by the operating system 931 932 if pthread_attr_setaffinity_np'Address = System.Null_Address then 933 null; 934 935 -- Support is available 936 937 elsif T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then 938 declare 939 CPUs : constant size_t := 940 Interfaces.C.size_t 941 (System.Multiprocessors.Number_Of_CPUs); 942 CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs); 943 Size : constant size_t := CPU_ALLOC_SIZE (CPUs); 944 945 begin 946 CPU_ZERO (Size, CPU_Set); 947 System.OS_Interface.CPU_SET 948 (int (T.Common.Base_CPU), Size, CPU_Set); 949 Result := 950 pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set); 951 pragma Assert (Result = 0); 952 953 CPU_FREE (CPU_Set); 954 end; 955 956 -- Handle Task_Info 957 958 elsif T.Common.Task_Info /= null then 959 Result := 960 pthread_attr_setaffinity_np 961 (Attributes'Access, 962 CPU_SETSIZE / 8, 963 T.Common.Task_Info.CPU_Affinity'Access); 964 pragma Assert (Result = 0); 965 966 -- Handle dispatching domains 967 968 -- To avoid changing CPU affinities when not needed, we set the 969 -- affinity only when assigning to a domain other than the default 970 -- one, or when the default one has been modified. 971 972 elsif T.Common.Domain /= null and then 973 (T.Common.Domain /= ST.System_Domain 974 or else T.Common.Domain.all /= 975 (Multiprocessors.CPU'First .. 976 Multiprocessors.Number_Of_CPUs => True)) 977 then 978 declare 979 CPUs : constant size_t := 980 Interfaces.C.size_t 981 (System.Multiprocessors.Number_Of_CPUs); 982 CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs); 983 Size : constant size_t := CPU_ALLOC_SIZE (CPUs); 984 985 begin 986 CPU_ZERO (Size, CPU_Set); 987 988 -- Set the affinity to all the processors belonging to the 989 -- dispatching domain. 990 991 for Proc in T.Common.Domain'Range loop 992 if T.Common.Domain (Proc) then 993 System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set); 994 end if; 995 end loop; 996 997 Result := 998 pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set); 999 pragma Assert (Result = 0); 1000 1001 CPU_FREE (CPU_Set); 1002 end; 1003 end if; 1004 1005 -- Since the initial signal mask of a thread is inherited from the 1006 -- creator, and the Environment task has all its signals masked, we 1007 -- do not need to manipulate caller's signal mask at this point. 1008 -- All tasks in RTS will have All_Tasks_Mask initially. 1009 1010 -- Note: the use of Unrestricted_Access in the following call is needed 1011 -- because otherwise we have an error of getting a access-to-volatile 1012 -- value which points to a non-volatile object. But in this case it is 1013 -- safe to do this, since we know we have no problems with aliasing and 1014 -- Unrestricted_Access bypasses this check. 1015 1016 Result := 1017 pthread_create 1018 (T.Common.LL.Thread'Unrestricted_Access, 1019 Attributes'Access, 1020 Thread_Body_Access (Wrapper), 1021 To_Address (T)); 1022 1023 pragma Assert 1024 (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); 1025 1026 if Result /= 0 then 1027 Succeeded := False; 1028 Result := pthread_attr_destroy (Attributes'Access); 1029 pragma Assert (Result = 0); 1030 return; 1031 end if; 1032 1033 Succeeded := True; 1034 1035 Result := pthread_attr_destroy (Attributes'Access); 1036 pragma Assert (Result = 0); 1037 1038 Set_Priority (T, Priority); 1039 end Create_Task; 1040 1041 ------------------ 1042 -- Finalize_TCB -- 1043 ------------------ 1044 1045 procedure Finalize_TCB (T : Task_Id) is 1046 Result : Interfaces.C.int; 1047 1048 begin 1049 if not Single_Lock then 1050 Result := pthread_mutex_destroy (T.Common.LL.L'Access); 1051 pragma Assert (Result = 0); 1052 end if; 1053 1054 Result := pthread_cond_destroy (T.Common.LL.CV'Access); 1055 pragma Assert (Result = 0); 1056 1057 if T.Known_Tasks_Index /= -1 then 1058 Known_Tasks (T.Known_Tasks_Index) := null; 1059 end if; 1060 1061 SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); 1062 1063 ATCB_Allocation.Free_ATCB (T); 1064 end Finalize_TCB; 1065 1066 --------------- 1067 -- Exit_Task -- 1068 --------------- 1069 1070 procedure Exit_Task is 1071 begin 1072 Specific.Set (null); 1073 end Exit_Task; 1074 1075 ---------------- 1076 -- Abort_Task -- 1077 ---------------- 1078 1079 procedure Abort_Task (T : Task_Id) is 1080 Result : Interfaces.C.int; 1081 begin 1082 if Abort_Handler_Installed then 1083 Result := 1084 pthread_kill 1085 (T.Common.LL.Thread, 1086 Signal (System.Interrupt_Management.Abort_Task_Interrupt)); 1087 pragma Assert (Result = 0); 1088 end if; 1089 end Abort_Task; 1090 1091 ---------------- 1092 -- Initialize -- 1093 ---------------- 1094 1095 procedure Initialize (S : in out Suspension_Object) is 1096 Result : Interfaces.C.int; 1097 1098 begin 1099 -- Initialize internal state (always to False (RM D.10(6))) 1100 1101 S.State := False; 1102 S.Waiting := False; 1103 1104 -- Initialize internal mutex 1105 1106 Result := pthread_mutex_init (S.L'Access, null); 1107 1108 pragma Assert (Result = 0 or else Result = ENOMEM); 1109 1110 if Result = ENOMEM then 1111 raise Storage_Error; 1112 end if; 1113 1114 -- Initialize internal condition variable 1115 1116 Result := pthread_cond_init (S.CV'Access, null); 1117 1118 pragma Assert (Result = 0 or else Result = ENOMEM); 1119 1120 if Result /= 0 then 1121 Result := pthread_mutex_destroy (S.L'Access); 1122 pragma Assert (Result = 0); 1123 1124 if Result = ENOMEM then 1125 raise Storage_Error; 1126 end if; 1127 end if; 1128 end Initialize; 1129 1130 -------------- 1131 -- Finalize -- 1132 -------------- 1133 1134 procedure Finalize (S : in out Suspension_Object) is 1135 Result : Interfaces.C.int; 1136 1137 begin 1138 -- Destroy internal mutex 1139 1140 Result := pthread_mutex_destroy (S.L'Access); 1141 pragma Assert (Result = 0); 1142 1143 -- Destroy internal condition variable 1144 1145 Result := pthread_cond_destroy (S.CV'Access); 1146 pragma Assert (Result = 0); 1147 end Finalize; 1148 1149 ------------------- 1150 -- Current_State -- 1151 ------------------- 1152 1153 function Current_State (S : Suspension_Object) return Boolean is 1154 begin 1155 -- We do not want to use lock on this read operation. State is marked 1156 -- as Atomic so that we ensure that the value retrieved is correct. 1157 1158 return S.State; 1159 end Current_State; 1160 1161 --------------- 1162 -- Set_False -- 1163 --------------- 1164 1165 procedure Set_False (S : in out Suspension_Object) is 1166 Result : Interfaces.C.int; 1167 1168 begin 1169 SSL.Abort_Defer.all; 1170 1171 Result := pthread_mutex_lock (S.L'Access); 1172 pragma Assert (Result = 0); 1173 1174 S.State := False; 1175 1176 Result := pthread_mutex_unlock (S.L'Access); 1177 pragma Assert (Result = 0); 1178 1179 SSL.Abort_Undefer.all; 1180 end Set_False; 1181 1182 -------------- 1183 -- Set_True -- 1184 -------------- 1185 1186 procedure Set_True (S : in out Suspension_Object) is 1187 Result : Interfaces.C.int; 1188 1189 begin 1190 SSL.Abort_Defer.all; 1191 1192 Result := pthread_mutex_lock (S.L'Access); 1193 pragma Assert (Result = 0); 1194 1195 -- If there is already a task waiting on this suspension object then 1196 -- we resume it, leaving the state of the suspension object to False, 1197 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves 1198 -- the state to True. 1199 1200 if S.Waiting then 1201 S.Waiting := False; 1202 S.State := False; 1203 1204 Result := pthread_cond_signal (S.CV'Access); 1205 pragma Assert (Result = 0); 1206 1207 else 1208 S.State := True; 1209 end if; 1210 1211 Result := pthread_mutex_unlock (S.L'Access); 1212 pragma Assert (Result = 0); 1213 1214 SSL.Abort_Undefer.all; 1215 end Set_True; 1216 1217 ------------------------ 1218 -- Suspend_Until_True -- 1219 ------------------------ 1220 1221 procedure Suspend_Until_True (S : in out Suspension_Object) is 1222 Result : Interfaces.C.int; 1223 1224 begin 1225 SSL.Abort_Defer.all; 1226 1227 Result := pthread_mutex_lock (S.L'Access); 1228 pragma Assert (Result = 0); 1229 1230 if S.Waiting then 1231 1232 -- Program_Error must be raised upon calling Suspend_Until_True 1233 -- if another task is already waiting on that suspension object 1234 -- (RM D.10(10)). 1235 1236 Result := pthread_mutex_unlock (S.L'Access); 1237 pragma Assert (Result = 0); 1238 1239 SSL.Abort_Undefer.all; 1240 1241 raise Program_Error; 1242 1243 else 1244 -- Suspend the task if the state is False. Otherwise, the task 1245 -- continues its execution, and the state of the suspension object 1246 -- is set to False (ARM D.10 par. 9). 1247 1248 if S.State then 1249 S.State := False; 1250 else 1251 S.Waiting := True; 1252 1253 loop 1254 -- Loop in case pthread_cond_wait returns earlier than expected 1255 -- (e.g. in case of EINTR caused by a signal). This should not 1256 -- happen with the current Linux implementation of pthread, but 1257 -- POSIX does not guarantee it so this may change in future. 1258 1259 Result := pthread_cond_wait (S.CV'Access, S.L'Access); 1260 pragma Assert (Result = 0 or else Result = EINTR); 1261 1262 exit when not S.Waiting; 1263 end loop; 1264 end if; 1265 1266 Result := pthread_mutex_unlock (S.L'Access); 1267 pragma Assert (Result = 0); 1268 1269 SSL.Abort_Undefer.all; 1270 end if; 1271 end Suspend_Until_True; 1272 1273 ---------------- 1274 -- Check_Exit -- 1275 ---------------- 1276 1277 -- Dummy version 1278 1279 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is 1280 pragma Unreferenced (Self_ID); 1281 begin 1282 return True; 1283 end Check_Exit; 1284 1285 -------------------- 1286 -- Check_No_Locks -- 1287 -------------------- 1288 1289 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is 1290 pragma Unreferenced (Self_ID); 1291 begin 1292 return True; 1293 end Check_No_Locks; 1294 1295 ---------------------- 1296 -- Environment_Task -- 1297 ---------------------- 1298 1299 function Environment_Task return Task_Id is 1300 begin 1301 return Environment_Task_Id; 1302 end Environment_Task; 1303 1304 ------------------ 1305 -- Suspend_Task -- 1306 ------------------ 1307 1308 function Suspend_Task 1309 (T : ST.Task_Id; 1310 Thread_Self : Thread_Id) return Boolean 1311 is 1312 begin 1313 if T.Common.LL.Thread /= Thread_Self then 1314 return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0; 1315 else 1316 return True; 1317 end if; 1318 end Suspend_Task; 1319 1320 ----------------- 1321 -- Resume_Task -- 1322 ----------------- 1323 1324 function Resume_Task 1325 (T : ST.Task_Id; 1326 Thread_Self : Thread_Id) return Boolean 1327 is 1328 begin 1329 if T.Common.LL.Thread /= Thread_Self then 1330 return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0; 1331 else 1332 return True; 1333 end if; 1334 end Resume_Task; 1335 1336 -------------------- 1337 -- Stop_All_Tasks -- 1338 -------------------- 1339 1340 procedure Stop_All_Tasks is 1341 begin 1342 null; 1343 end Stop_All_Tasks; 1344 1345 --------------- 1346 -- Stop_Task -- 1347 --------------- 1348 1349 function Stop_Task (T : ST.Task_Id) return Boolean is 1350 pragma Unreferenced (T); 1351 begin 1352 return False; 1353 end Stop_Task; 1354 1355 ------------------- 1356 -- Continue_Task -- 1357 ------------------- 1358 1359 function Continue_Task (T : ST.Task_Id) return Boolean is 1360 pragma Unreferenced (T); 1361 begin 1362 return False; 1363 end Continue_Task; 1364 1365 ---------------- 1366 -- Initialize -- 1367 ---------------- 1368 1369 procedure Initialize (Environment_Task : Task_Id) is 1370 act : aliased struct_sigaction; 1371 old_act : aliased struct_sigaction; 1372 Tmp_Set : aliased sigset_t; 1373 Result : Interfaces.C.int; 1374 -- Whether to use an alternate signal stack for stack overflows 1375 1376 function State 1377 (Int : System.Interrupt_Management.Interrupt_ID) return Character; 1378 pragma Import (C, State, "__gnat_get_interrupt_state"); 1379 -- Get interrupt state. Defined in a-init.c 1380 -- The input argument is the interrupt number, 1381 -- and the result is one of the following: 1382 1383 Default : constant Character := 's'; 1384 -- 'n' this interrupt not set by any Interrupt_State pragma 1385 -- 'u' Interrupt_State pragma set state to User 1386 -- 'r' Interrupt_State pragma set state to Runtime 1387 -- 's' Interrupt_State pragma set state to System (use "default" 1388 -- system handler) 1389 1390 use type System.Multiprocessors.CPU_Range; 1391 1392 begin 1393 Environment_Task_Id := Environment_Task; 1394 1395 Interrupt_Management.Initialize; 1396 1397 -- Prepare the set of signals that should be unblocked in all tasks 1398 1399 Result := sigemptyset (Unblocked_Signal_Mask'Access); 1400 pragma Assert (Result = 0); 1401 1402 for J in Interrupt_Management.Interrupt_ID loop 1403 if System.Interrupt_Management.Keep_Unmasked (J) then 1404 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); 1405 pragma Assert (Result = 0); 1406 end if; 1407 end loop; 1408 1409 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1410 1411 -- Initialize the global RTS lock 1412 1413 Specific.Initialize (Environment_Task); 1414 1415 if Use_Alternate_Stack then 1416 Environment_Task.Common.Task_Alternate_Stack := 1417 Alternate_Stack'Address; 1418 end if; 1419 1420 -- Make environment task known here because it doesn't go through 1421 -- Activate_Tasks, which does it for all other tasks. 1422 1423 Known_Tasks (Known_Tasks'First) := Environment_Task; 1424 Environment_Task.Known_Tasks_Index := Known_Tasks'First; 1425 1426 Enter_Task (Environment_Task); 1427 1428 if State 1429 (System.Interrupt_Management.Abort_Task_Interrupt) /= Default 1430 then 1431 act.sa_flags := 0; 1432 act.sa_handler := Abort_Handler'Address; 1433 1434 Result := sigemptyset (Tmp_Set'Access); 1435 pragma Assert (Result = 0); 1436 act.sa_mask := Tmp_Set; 1437 1438 Result := 1439 sigaction 1440 (Signal (Interrupt_Management.Abort_Task_Interrupt), 1441 act'Unchecked_Access, 1442 old_act'Unchecked_Access); 1443 pragma Assert (Result = 0); 1444 Abort_Handler_Installed := True; 1445 end if; 1446 1447 -- pragma CPU and dispatching domains for the environment task 1448 1449 Set_Task_Affinity (Environment_Task); 1450 end Initialize; 1451 1452 ----------------------- 1453 -- Set_Task_Affinity -- 1454 ----------------------- 1455 1456 procedure Set_Task_Affinity (T : ST.Task_Id) is 1457 use type System.Multiprocessors.CPU_Range; 1458 1459 begin 1460 -- Do nothing if there is no support for setting affinities or the 1461 -- underlying thread has not yet been created. If the thread has not 1462 -- yet been created then the proper affinity will be set during its 1463 -- creation. 1464 1465 if pthread_setaffinity_np'Address /= System.Null_Address 1466 and then T.Common.LL.Thread /= Null_Thread_Id 1467 then 1468 declare 1469 CPUs : constant size_t := 1470 Interfaces.C.size_t 1471 (System.Multiprocessors.Number_Of_CPUs); 1472 CPU_Set : cpu_set_t_ptr := null; 1473 Size : constant size_t := CPU_ALLOC_SIZE (CPUs); 1474 1475 Result : Interfaces.C.int; 1476 1477 begin 1478 -- We look at the specific CPU (Base_CPU) first, then at the 1479 -- Task_Info field, and finally at the assigned dispatching 1480 -- domain, if any. 1481 1482 if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then 1483 1484 -- Set the affinity to an unique CPU 1485 1486 CPU_Set := CPU_ALLOC (CPUs); 1487 System.OS_Interface.CPU_ZERO (Size, CPU_Set); 1488 System.OS_Interface.CPU_SET 1489 (int (T.Common.Base_CPU), Size, CPU_Set); 1490 1491 -- Handle Task_Info 1492 1493 elsif T.Common.Task_Info /= null then 1494 CPU_Set := T.Common.Task_Info.CPU_Affinity'Access; 1495 1496 -- Handle dispatching domains 1497 1498 elsif T.Common.Domain /= null and then 1499 (T.Common.Domain /= ST.System_Domain 1500 or else T.Common.Domain.all /= 1501 (Multiprocessors.CPU'First .. 1502 Multiprocessors.Number_Of_CPUs => True)) 1503 then 1504 -- Set the affinity to all the processors belonging to the 1505 -- dispatching domain. To avoid changing CPU affinities when 1506 -- not needed, we set the affinity only when assigning to a 1507 -- domain other than the default one, or when the default one 1508 -- has been modified. 1509 1510 CPU_Set := CPU_ALLOC (CPUs); 1511 System.OS_Interface.CPU_ZERO (Size, CPU_Set); 1512 1513 for Proc in T.Common.Domain'Range loop 1514 System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set); 1515 end loop; 1516 end if; 1517 1518 -- We set the new affinity if needed. Otherwise, the new task 1519 -- will inherit its creator's CPU affinity mask (according to 1520 -- the documentation of pthread_setaffinity_np), which is 1521 -- consistent with Ada's required semantics. 1522 1523 if CPU_Set /= null then 1524 Result := 1525 pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set); 1526 pragma Assert (Result = 0); 1527 1528 CPU_FREE (CPU_Set); 1529 end if; 1530 end; 1531 end if; 1532 end Set_Task_Affinity; 1533 1534end System.Task_Primitives.Operations; 1535