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