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-2019, 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 package Monotonic is 149 150 function Monotonic_Clock return Duration; 151 pragma Inline (Monotonic_Clock); 152 -- Returns an absolute time, represented as an offset relative to some 153 -- unspecified starting point, typically system boot time. This clock 154 -- is not affected by discontinuous jumps in the system time. 155 156 function RT_Resolution return Duration; 157 pragma Inline (RT_Resolution); 158 -- Returns resolution of the underlying clock used to implement RT_Clock 159 160 procedure Timed_Sleep 161 (Self_ID : ST.Task_Id; 162 Time : Duration; 163 Mode : ST.Delay_Modes; 164 Reason : System.Tasking.Task_States; 165 Timedout : out Boolean; 166 Yielded : out Boolean); 167 -- Combination of Sleep (above) and Timed_Delay 168 169 procedure Timed_Delay 170 (Self_ID : ST.Task_Id; 171 Time : Duration; 172 Mode : ST.Delay_Modes); 173 -- Implement the semantics of the delay statement. 174 -- The caller should be abort-deferred and should not hold any locks. 175 176 end Monotonic; 177 178 package body Monotonic is separate; 179 180 ---------------------------------- 181 -- ATCB allocation/deallocation -- 182 ---------------------------------- 183 184 package body ATCB_Allocation is separate; 185 -- The body of this package is shared across several targets 186 187 --------------------------------- 188 -- Support for foreign threads -- 189 --------------------------------- 190 191 function Register_Foreign_Thread 192 (Thread : Thread_Id; 193 Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; 194 -- Allocate and initialize a new ATCB for the current Thread. The size of 195 -- the secondary stack can be optionally specified. 196 197 function Register_Foreign_Thread 198 (Thread : Thread_Id; 199 Sec_Stack_Size : Size_Type := Unspecified_Size) 200 return Task_Id is separate; 201 202 ----------------------- 203 -- Local Subprograms -- 204 ----------------------- 205 206 procedure Abort_Handler (Sig : Signal); 207 -- Signal handler used to implement asynchronous abort. 208 -- See also comment before body, below. 209 210 function To_Address is 211 new Ada.Unchecked_Conversion (Task_Id, System.Address); 212 213 function GNAT_pthread_condattr_setup 214 (attr : access pthread_condattr_t) return int; 215 pragma Import (C, 216 GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); 217 218 ------------------- 219 -- Abort_Handler -- 220 ------------------- 221 222 -- Target-dependent binding of inter-thread Abort signal to the raising of 223 -- the Abort_Signal exception. 224 225 -- The technical issues and alternatives here are essentially the 226 -- same as for raising exceptions in response to other signals 227 -- (e.g. Storage_Error). See code and comments in the package body 228 -- System.Interrupt_Management. 229 230 -- Some implementations may not allow an exception to be propagated out of 231 -- a handler, and others might leave the signal or interrupt that invoked 232 -- this handler masked after the exceptional return to the application 233 -- code. 234 235 -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On 236 -- most UNIX systems, this will allow transfer out of a signal handler, 237 -- which is usually the only mechanism available for implementing 238 -- asynchronous handlers of this kind. However, some systems do not 239 -- restore the signal mask on longjmp(), leaving the abort signal masked. 240 241 procedure Abort_Handler (Sig : Signal) is 242 pragma Unreferenced (Sig); 243 244 T : constant Task_Id := Self; 245 Old_Set : aliased sigset_t; 246 247 Result : Interfaces.C.int; 248 pragma Warnings (Off, Result); 249 250 begin 251 -- It's not safe to raise an exception when using GCC ZCX mechanism. 252 -- Note that we still need to install a signal handler, since in some 253 -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we 254 -- need to send the Abort signal to a task. 255 256 if ZCX_By_Default then 257 return; 258 end if; 259 260 if T.Deferral_Level = 0 261 and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then 262 not T.Aborting 263 then 264 T.Aborting := True; 265 266 -- Make sure signals used for RTS internal purpose are unmasked 267 268 Result := pthread_sigmask (SIG_UNBLOCK, 269 Unblocked_Signal_Mask'Access, Old_Set'Access); 270 pragma Assert (Result = 0); 271 272 raise Standard'Abort_Signal; 273 end if; 274 end Abort_Handler; 275 276 ----------------- 277 -- Stack_Guard -- 278 ----------------- 279 280 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is 281 Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); 282 Page_Size : Address; 283 Res : Interfaces.C.int; 284 285 begin 286 if Stack_Base_Available then 287 288 -- Compute the guard page address 289 290 Page_Size := Address (Get_Page_Size); 291 Res := 292 mprotect 293 (Stack_Base - (Stack_Base mod Page_Size) + Page_Size, 294 size_t (Page_Size), 295 prot => (if On then PROT_ON else PROT_OFF)); 296 pragma Assert (Res = 0); 297 end if; 298 end Stack_Guard; 299 300 -------------------- 301 -- Get_Thread_Id -- 302 -------------------- 303 304 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is 305 begin 306 return T.Common.LL.Thread; 307 end Get_Thread_Id; 308 309 ---------- 310 -- Self -- 311 ---------- 312 313 function Self return Task_Id renames Specific.Self; 314 315 --------------------- 316 -- Initialize_Lock -- 317 --------------------- 318 319 -- Note: mutexes and cond_variables needed per-task basis are initialized 320 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such 321 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any 322 -- status change of RTS. Therefore raising Storage_Error in the following 323 -- routines should be able to be handled safely. 324 325 procedure Initialize_Lock 326 (Prio : System.Any_Priority; 327 L : not null access Lock) 328 is 329 Attributes : aliased pthread_mutexattr_t; 330 Result : Interfaces.C.int; 331 332 begin 333 Result := pthread_mutexattr_init (Attributes'Access); 334 pragma Assert (Result = 0 or else Result = ENOMEM); 335 336 if Result = ENOMEM then 337 raise Storage_Error; 338 end if; 339 340 if Locking_Policy = 'C' then 341 Result := pthread_mutexattr_setprotocol 342 (Attributes'Access, PTHREAD_PRIO_PROTECT); 343 pragma Assert (Result = 0); 344 345 Result := pthread_mutexattr_setprioceiling 346 (Attributes'Access, Interfaces.C.int (Prio)); 347 pragma Assert (Result = 0); 348 349 elsif Locking_Policy = 'I' then 350 Result := pthread_mutexattr_setprotocol 351 (Attributes'Access, PTHREAD_PRIO_INHERIT); 352 pragma Assert (Result = 0); 353 end if; 354 355 Result := pthread_mutex_init (L.WO'Access, Attributes'Access); 356 pragma Assert (Result = 0 or else Result = ENOMEM); 357 358 if Result = ENOMEM then 359 Result := pthread_mutexattr_destroy (Attributes'Access); 360 raise Storage_Error; 361 end if; 362 363 Result := pthread_mutexattr_destroy (Attributes'Access); 364 pragma Assert (Result = 0); 365 end Initialize_Lock; 366 367 procedure Initialize_Lock 368 (L : not null access RTS_Lock; Level : Lock_Level) 369 is 370 pragma Unreferenced (Level); 371 372 Attributes : aliased pthread_mutexattr_t; 373 Result : Interfaces.C.int; 374 375 begin 376 Result := pthread_mutexattr_init (Attributes'Access); 377 pragma Assert (Result = 0 or else Result = ENOMEM); 378 379 if Result = ENOMEM then 380 raise Storage_Error; 381 end if; 382 383 if Locking_Policy = 'C' then 384 Result := pthread_mutexattr_setprotocol 385 (Attributes'Access, PTHREAD_PRIO_PROTECT); 386 pragma Assert (Result = 0); 387 388 Result := pthread_mutexattr_setprioceiling 389 (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); 390 pragma Assert (Result = 0); 391 392 elsif Locking_Policy = 'I' then 393 Result := pthread_mutexattr_setprotocol 394 (Attributes'Access, PTHREAD_PRIO_INHERIT); 395 pragma Assert (Result = 0); 396 end if; 397 398 Result := pthread_mutex_init (L, Attributes'Access); 399 pragma Assert (Result = 0 or else Result = ENOMEM); 400 401 if Result = ENOMEM then 402 Result := pthread_mutexattr_destroy (Attributes'Access); 403 raise Storage_Error; 404 end if; 405 406 Result := pthread_mutexattr_destroy (Attributes'Access); 407 pragma Assert (Result = 0); 408 end Initialize_Lock; 409 410 ------------------- 411 -- Finalize_Lock -- 412 ------------------- 413 414 procedure Finalize_Lock (L : not null access Lock) is 415 Result : Interfaces.C.int; 416 begin 417 Result := pthread_mutex_destroy (L.WO'Access); 418 pragma Assert (Result = 0); 419 end Finalize_Lock; 420 421 procedure Finalize_Lock (L : not null access RTS_Lock) is 422 Result : Interfaces.C.int; 423 begin 424 Result := pthread_mutex_destroy (L); 425 pragma Assert (Result = 0); 426 end Finalize_Lock; 427 428 ---------------- 429 -- Write_Lock -- 430 ---------------- 431 432 procedure Write_Lock 433 (L : not null access Lock; Ceiling_Violation : out Boolean) 434 is 435 Result : Interfaces.C.int; 436 437 begin 438 Result := pthread_mutex_lock (L.WO'Access); 439 440 -- The cause of EINVAL is a priority ceiling violation 441 442 Ceiling_Violation := Result = EINVAL; 443 pragma Assert (Result = 0 or else Ceiling_Violation); 444 end Write_Lock; 445 446 procedure Write_Lock 447 (L : not null access RTS_Lock; 448 Global_Lock : Boolean := False) 449 is 450 Result : Interfaces.C.int; 451 begin 452 if not Single_Lock or else Global_Lock then 453 Result := pthread_mutex_lock (L); 454 pragma Assert (Result = 0); 455 end if; 456 end Write_Lock; 457 458 procedure Write_Lock (T : Task_Id) is 459 Result : Interfaces.C.int; 460 begin 461 if not Single_Lock then 462 Result := pthread_mutex_lock (T.Common.LL.L'Access); 463 pragma Assert (Result = 0); 464 end if; 465 end Write_Lock; 466 467 --------------- 468 -- Read_Lock -- 469 --------------- 470 471 procedure Read_Lock 472 (L : not null access Lock; Ceiling_Violation : out Boolean) is 473 begin 474 Write_Lock (L, Ceiling_Violation); 475 end Read_Lock; 476 477 ------------ 478 -- Unlock -- 479 ------------ 480 481 procedure Unlock (L : not null access Lock) is 482 Result : Interfaces.C.int; 483 begin 484 Result := pthread_mutex_unlock (L.WO'Access); 485 pragma Assert (Result = 0); 486 end Unlock; 487 488 procedure Unlock 489 (L : not null access RTS_Lock; Global_Lock : Boolean := False) 490 is 491 Result : Interfaces.C.int; 492 begin 493 if not Single_Lock or else Global_Lock then 494 Result := pthread_mutex_unlock (L); 495 pragma Assert (Result = 0); 496 end if; 497 end Unlock; 498 499 procedure Unlock (T : Task_Id) is 500 Result : Interfaces.C.int; 501 begin 502 if not Single_Lock then 503 Result := pthread_mutex_unlock (T.Common.LL.L'Access); 504 pragma Assert (Result = 0); 505 end if; 506 end Unlock; 507 508 ----------------- 509 -- Set_Ceiling -- 510 ----------------- 511 512 -- Dynamic priority ceilings are not supported by the underlying system 513 514 procedure Set_Ceiling 515 (L : not null access Lock; 516 Prio : System.Any_Priority) 517 is 518 pragma Unreferenced (L, Prio); 519 begin 520 null; 521 end Set_Ceiling; 522 523 ----------- 524 -- Sleep -- 525 ----------- 526 527 procedure Sleep 528 (Self_ID : Task_Id; 529 Reason : System.Tasking.Task_States) 530 is 531 pragma Unreferenced (Reason); 532 533 Result : Interfaces.C.int; 534 535 begin 536 Result := 537 pthread_cond_wait 538 (cond => Self_ID.Common.LL.CV'Access, 539 mutex => (if Single_Lock 540 then Single_RTS_Lock'Access 541 else Self_ID.Common.LL.L'Access)); 542 543 -- EINTR is not considered a failure 544 545 pragma Assert (Result = 0 or else Result = EINTR); 546 end Sleep; 547 548 ----------------- 549 -- Timed_Sleep -- 550 ----------------- 551 552 -- This is for use within the run-time system, so abort is 553 -- assumed to be already deferred, and the caller should be 554 -- holding its own ATCB lock. 555 556 procedure Timed_Sleep 557 (Self_ID : Task_Id; 558 Time : Duration; 559 Mode : ST.Delay_Modes; 560 Reason : Task_States; 561 Timedout : out Boolean; 562 Yielded : out Boolean) renames Monotonic.Timed_Sleep; 563 564 ----------------- 565 -- Timed_Delay -- 566 ----------------- 567 568 -- This is for use in implementing delay statements, so we assume the 569 -- caller is abort-deferred but is holding no locks. 570 571 procedure Timed_Delay 572 (Self_ID : Task_Id; 573 Time : Duration; 574 Mode : ST.Delay_Modes) renames Monotonic.Timed_Delay; 575 576 --------------------- 577 -- Monotonic_Clock -- 578 --------------------- 579 580 function Monotonic_Clock return Duration renames Monotonic.Monotonic_Clock; 581 582 ------------------- 583 -- RT_Resolution -- 584 ------------------- 585 586 function RT_Resolution return Duration renames Monotonic.RT_Resolution; 587 588 ------------ 589 -- Wakeup -- 590 ------------ 591 592 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is 593 pragma Unreferenced (Reason); 594 Result : Interfaces.C.int; 595 begin 596 Result := pthread_cond_signal (T.Common.LL.CV'Access); 597 pragma Assert (Result = 0); 598 end Wakeup; 599 600 ----------- 601 -- Yield -- 602 ----------- 603 604 procedure Yield (Do_Yield : Boolean := True) is 605 Result : Interfaces.C.int; 606 pragma Unreferenced (Result); 607 begin 608 if Do_Yield then 609 Result := sched_yield; 610 end if; 611 end Yield; 612 613 ------------------ 614 -- Set_Priority -- 615 ------------------ 616 617 procedure Set_Priority 618 (T : Task_Id; 619 Prio : System.Any_Priority; 620 Loss_Of_Inheritance : Boolean := False) 621 is 622 pragma Unreferenced (Loss_Of_Inheritance); 623 624 Result : Interfaces.C.int; 625 Param : aliased struct_sched_param; 626 627 function Get_Policy (Prio : System.Any_Priority) return Character; 628 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); 629 -- Get priority specific dispatching policy 630 631 Priority_Specific_Policy : constant Character := Get_Policy (Prio); 632 -- Upper case first character of the policy name corresponding to the 633 -- task as set by a Priority_Specific_Dispatching pragma. 634 635 begin 636 T.Common.Current_Priority := Prio; 637 Param.sched_priority := To_Target_Priority (Prio); 638 639 if Time_Slice_Supported 640 and then (Dispatching_Policy = 'R' 641 or else Priority_Specific_Policy = 'R' 642 or else Time_Slice_Val > 0) 643 then 644 Result := pthread_setschedparam 645 (T.Common.LL.Thread, SCHED_RR, Param'Access); 646 647 elsif Dispatching_Policy = 'F' 648 or else Priority_Specific_Policy = 'F' 649 or else Time_Slice_Val = 0 650 then 651 Result := pthread_setschedparam 652 (T.Common.LL.Thread, SCHED_FIFO, Param'Access); 653 654 else 655 Result := pthread_setschedparam 656 (T.Common.LL.Thread, SCHED_OTHER, Param'Access); 657 end if; 658 659 pragma Assert (Result = 0); 660 end Set_Priority; 661 662 ------------------ 663 -- Get_Priority -- 664 ------------------ 665 666 function Get_Priority (T : Task_Id) return System.Any_Priority is 667 begin 668 return T.Common.Current_Priority; 669 end Get_Priority; 670 671 ---------------- 672 -- Enter_Task -- 673 ---------------- 674 675 procedure Enter_Task (Self_ID : Task_Id) is 676 begin 677 Self_ID.Common.LL.Thread := pthread_self; 678 Self_ID.Common.LL.LWP := lwp_self; 679 680 Specific.Set (Self_ID); 681 682 if Use_Alternate_Stack then 683 declare 684 Stack : aliased stack_t; 685 Result : Interfaces.C.int; 686 begin 687 Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; 688 Stack.ss_size := Alternate_Stack_Size; 689 Stack.ss_flags := 0; 690 Result := sigaltstack (Stack'Access, null); 691 pragma Assert (Result = 0); 692 end; 693 end if; 694 end Enter_Task; 695 696 ------------------- 697 -- Is_Valid_Task -- 698 ------------------- 699 700 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 701 702 ----------------------------- 703 -- Register_Foreign_Thread -- 704 ----------------------------- 705 706 function Register_Foreign_Thread return Task_Id is 707 begin 708 if Is_Valid_Task then 709 return Self; 710 else 711 return Register_Foreign_Thread (pthread_self); 712 end if; 713 end Register_Foreign_Thread; 714 715 -------------------- 716 -- Initialize_TCB -- 717 -------------------- 718 719 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is 720 Mutex_Attr : aliased pthread_mutexattr_t; 721 Result : Interfaces.C.int; 722 Cond_Attr : aliased pthread_condattr_t; 723 724 begin 725 -- Give the task a unique serial number 726 727 Self_ID.Serial_Number := Next_Serial_Number; 728 Next_Serial_Number := Next_Serial_Number + 1; 729 pragma Assert (Next_Serial_Number /= 0); 730 731 if not Single_Lock then 732 Result := pthread_mutexattr_init (Mutex_Attr'Access); 733 pragma Assert (Result = 0 or else Result = ENOMEM); 734 735 if Result = 0 then 736 if Locking_Policy = 'C' then 737 Result := 738 pthread_mutexattr_setprotocol 739 (Mutex_Attr'Access, 740 PTHREAD_PRIO_PROTECT); 741 pragma Assert (Result = 0); 742 743 Result := 744 pthread_mutexattr_setprioceiling 745 (Mutex_Attr'Access, 746 Interfaces.C.int (System.Any_Priority'Last)); 747 pragma Assert (Result = 0); 748 749 elsif Locking_Policy = 'I' then 750 Result := 751 pthread_mutexattr_setprotocol 752 (Mutex_Attr'Access, 753 PTHREAD_PRIO_INHERIT); 754 pragma Assert (Result = 0); 755 end if; 756 757 Result := 758 pthread_mutex_init 759 (Self_ID.Common.LL.L'Access, 760 Mutex_Attr'Access); 761 pragma Assert (Result = 0 or else Result = ENOMEM); 762 end if; 763 764 if Result /= 0 then 765 Succeeded := False; 766 return; 767 end if; 768 769 Result := pthread_mutexattr_destroy (Mutex_Attr'Access); 770 pragma Assert (Result = 0); 771 end if; 772 773 Result := pthread_condattr_init (Cond_Attr'Access); 774 pragma Assert (Result = 0 or else Result = ENOMEM); 775 776 if Result = 0 then 777 Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); 778 pragma Assert (Result = 0); 779 780 Result := 781 pthread_cond_init 782 (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); 783 pragma Assert (Result = 0 or else Result = ENOMEM); 784 end if; 785 786 if Result = 0 then 787 Succeeded := True; 788 else 789 if not Single_Lock then 790 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); 791 pragma Assert (Result = 0); 792 end if; 793 794 Succeeded := False; 795 end if; 796 797 Result := pthread_condattr_destroy (Cond_Attr'Access); 798 pragma Assert (Result = 0); 799 end Initialize_TCB; 800 801 ----------------- 802 -- Create_Task -- 803 ----------------- 804 805 procedure Create_Task 806 (T : Task_Id; 807 Wrapper : System.Address; 808 Stack_Size : System.Parameters.Size_Type; 809 Priority : System.Any_Priority; 810 Succeeded : out Boolean) 811 is 812 Attributes : aliased pthread_attr_t; 813 Adjusted_Stack_Size : Interfaces.C.size_t; 814 Page_Size : constant Interfaces.C.size_t := 815 Interfaces.C.size_t (Get_Page_Size); 816 Result : Interfaces.C.int; 817 818 function Thread_Body_Access is new 819 Ada.Unchecked_Conversion (System.Address, Thread_Body); 820 821 use System.Task_Info; 822 823 begin 824 Adjusted_Stack_Size := 825 Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); 826 827 if Stack_Base_Available then 828 829 -- If Stack Checking is supported then allocate 2 additional pages: 830 831 -- In the worst case, stack is allocated at something like 832 -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages 833 -- to be sure the effective stack size is greater than what 834 -- has been asked. 835 836 Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size; 837 end if; 838 839 -- Round stack size as this is required by some OSes (Darwin) 840 841 Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1; 842 Adjusted_Stack_Size := 843 Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size; 844 845 Result := pthread_attr_init (Attributes'Access); 846 pragma Assert (Result = 0 or else Result = ENOMEM); 847 848 if Result /= 0 then 849 Succeeded := False; 850 return; 851 end if; 852 853 Result := 854 pthread_attr_setdetachstate 855 (Attributes'Access, PTHREAD_CREATE_DETACHED); 856 pragma Assert (Result = 0); 857 858 Result := 859 pthread_attr_setstacksize 860 (Attributes'Access, Adjusted_Stack_Size); 861 pragma Assert (Result = 0); 862 863 if T.Common.Task_Info /= Default_Scope then 864 case T.Common.Task_Info is 865 when System.Task_Info.Process_Scope => 866 Result := 867 pthread_attr_setscope 868 (Attributes'Access, PTHREAD_SCOPE_PROCESS); 869 870 when System.Task_Info.System_Scope => 871 Result := 872 pthread_attr_setscope 873 (Attributes'Access, PTHREAD_SCOPE_SYSTEM); 874 875 when System.Task_Info.Default_Scope => 876 Result := 0; 877 end case; 878 879 pragma Assert (Result = 0); 880 end if; 881 882 -- Since the initial signal mask of a thread is inherited from the 883 -- creator, and the Environment task has all its signals masked, we 884 -- do not need to manipulate caller's signal mask at this point. 885 -- All tasks in RTS will have All_Tasks_Mask initially. 886 887 -- Note: the use of Unrestricted_Access in the following call is needed 888 -- because otherwise we have an error of getting a access-to-volatile 889 -- value which points to a non-volatile object. But in this case it is 890 -- safe to do this, since we know we have no problems with aliasing and 891 -- Unrestricted_Access bypasses this check. 892 893 Result := pthread_create 894 (T.Common.LL.Thread'Unrestricted_Access, 895 Attributes'Access, 896 Thread_Body_Access (Wrapper), 897 To_Address (T)); 898 pragma Assert (Result = 0 or else Result = EAGAIN); 899 900 Succeeded := Result = 0; 901 902 Result := pthread_attr_destroy (Attributes'Access); 903 pragma Assert (Result = 0); 904 905 if Succeeded then 906 Set_Priority (T, Priority); 907 end if; 908 end Create_Task; 909 910 ------------------ 911 -- Finalize_TCB -- 912 ------------------ 913 914 procedure Finalize_TCB (T : Task_Id) is 915 Result : Interfaces.C.int; 916 917 begin 918 if not Single_Lock then 919 Result := pthread_mutex_destroy (T.Common.LL.L'Access); 920 pragma Assert (Result = 0); 921 end if; 922 923 Result := pthread_cond_destroy (T.Common.LL.CV'Access); 924 pragma Assert (Result = 0); 925 926 if T.Known_Tasks_Index /= -1 then 927 Known_Tasks (T.Known_Tasks_Index) := null; 928 end if; 929 930 ATCB_Allocation.Free_ATCB (T); 931 end Finalize_TCB; 932 933 --------------- 934 -- Exit_Task -- 935 --------------- 936 937 procedure Exit_Task is 938 begin 939 -- Mark this task as unknown, so that if Self is called, it won't 940 -- return a dangling pointer. 941 942 Specific.Set (null); 943 end Exit_Task; 944 945 ---------------- 946 -- Abort_Task -- 947 ---------------- 948 949 procedure Abort_Task (T : Task_Id) is 950 Result : Interfaces.C.int; 951 begin 952 if Abort_Handler_Installed then 953 Result := 954 pthread_kill 955 (T.Common.LL.Thread, 956 Signal (System.Interrupt_Management.Abort_Task_Interrupt)); 957 pragma Assert (Result = 0); 958 end if; 959 end Abort_Task; 960 961 ---------------- 962 -- Initialize -- 963 ---------------- 964 965 procedure Initialize (S : in out Suspension_Object) is 966 Mutex_Attr : aliased pthread_mutexattr_t; 967 Cond_Attr : aliased pthread_condattr_t; 968 Result : Interfaces.C.int; 969 970 begin 971 -- Initialize internal state (always to False (RM D.10 (6))) 972 973 S.State := False; 974 S.Waiting := False; 975 976 -- Initialize internal mutex 977 978 Result := pthread_mutexattr_init (Mutex_Attr'Access); 979 pragma Assert (Result = 0 or else Result = ENOMEM); 980 981 if Result = ENOMEM then 982 raise Storage_Error; 983 end if; 984 985 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); 986 pragma Assert (Result = 0 or else Result = ENOMEM); 987 988 if Result = ENOMEM then 989 Result := pthread_mutexattr_destroy (Mutex_Attr'Access); 990 pragma Assert (Result = 0); 991 992 raise Storage_Error; 993 end if; 994 995 Result := pthread_mutexattr_destroy (Mutex_Attr'Access); 996 pragma Assert (Result = 0); 997 998 -- Initialize internal condition variable 999 1000 Result := pthread_condattr_init (Cond_Attr'Access); 1001 pragma Assert (Result = 0 or else Result = ENOMEM); 1002 1003 if Result /= 0 then 1004 Result := pthread_mutex_destroy (S.L'Access); 1005 pragma Assert (Result = 0); 1006 1007 -- Storage_Error is propagated as intended if the allocation of the 1008 -- underlying OS entities fails. 1009 1010 raise Storage_Error; 1011 1012 else 1013 Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); 1014 pragma Assert (Result = 0); 1015 end if; 1016 1017 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); 1018 pragma Assert (Result = 0 or else Result = ENOMEM); 1019 1020 if Result /= 0 then 1021 Result := pthread_mutex_destroy (S.L'Access); 1022 pragma Assert (Result = 0); 1023 1024 Result := pthread_condattr_destroy (Cond_Attr'Access); 1025 pragma Assert (Result = 0); 1026 1027 -- Storage_Error is propagated as intended if the allocation of the 1028 -- underlying OS entities fails. 1029 1030 raise Storage_Error; 1031 end if; 1032 1033 Result := pthread_condattr_destroy (Cond_Attr'Access); 1034 pragma Assert (Result = 0); 1035 end Initialize; 1036 1037 -------------- 1038 -- Finalize -- 1039 -------------- 1040 1041 procedure Finalize (S : in out Suspension_Object) is 1042 Result : Interfaces.C.int; 1043 1044 begin 1045 -- Destroy internal mutex 1046 1047 Result := pthread_mutex_destroy (S.L'Access); 1048 pragma Assert (Result = 0); 1049 1050 -- Destroy internal condition variable 1051 1052 Result := pthread_cond_destroy (S.CV'Access); 1053 pragma Assert (Result = 0); 1054 end Finalize; 1055 1056 ------------------- 1057 -- Current_State -- 1058 ------------------- 1059 1060 function Current_State (S : Suspension_Object) return Boolean is 1061 begin 1062 -- We do not want to use lock on this read operation. State is marked 1063 -- as Atomic so that we ensure that the value retrieved is correct. 1064 1065 return S.State; 1066 end Current_State; 1067 1068 --------------- 1069 -- Set_False -- 1070 --------------- 1071 1072 procedure Set_False (S : in out Suspension_Object) is 1073 Result : Interfaces.C.int; 1074 1075 begin 1076 SSL.Abort_Defer.all; 1077 1078 Result := pthread_mutex_lock (S.L'Access); 1079 pragma Assert (Result = 0); 1080 1081 S.State := False; 1082 1083 Result := pthread_mutex_unlock (S.L'Access); 1084 pragma Assert (Result = 0); 1085 1086 SSL.Abort_Undefer.all; 1087 end Set_False; 1088 1089 -------------- 1090 -- Set_True -- 1091 -------------- 1092 1093 procedure Set_True (S : in out Suspension_Object) is 1094 Result : Interfaces.C.int; 1095 1096 begin 1097 SSL.Abort_Defer.all; 1098 1099 Result := pthread_mutex_lock (S.L'Access); 1100 pragma Assert (Result = 0); 1101 1102 -- If there is already a task waiting on this suspension object then 1103 -- we resume it, leaving the state of the suspension object to False, 1104 -- as it is specified in (RM D.10(9)). Otherwise, it just leaves 1105 -- the state to True. 1106 1107 if S.Waiting then 1108 S.Waiting := False; 1109 S.State := False; 1110 1111 Result := pthread_cond_signal (S.CV'Access); 1112 pragma Assert (Result = 0); 1113 1114 else 1115 S.State := True; 1116 end if; 1117 1118 Result := pthread_mutex_unlock (S.L'Access); 1119 pragma Assert (Result = 0); 1120 1121 SSL.Abort_Undefer.all; 1122 end Set_True; 1123 1124 ------------------------ 1125 -- Suspend_Until_True -- 1126 ------------------------ 1127 1128 procedure Suspend_Until_True (S : in out Suspension_Object) is 1129 Result : Interfaces.C.int; 1130 1131 begin 1132 SSL.Abort_Defer.all; 1133 1134 Result := pthread_mutex_lock (S.L'Access); 1135 pragma Assert (Result = 0); 1136 1137 if S.Waiting then 1138 1139 -- Program_Error must be raised upon calling Suspend_Until_True 1140 -- if another task is already waiting on that suspension object 1141 -- (RM D.10(10)). 1142 1143 Result := pthread_mutex_unlock (S.L'Access); 1144 pragma Assert (Result = 0); 1145 1146 SSL.Abort_Undefer.all; 1147 1148 raise Program_Error; 1149 1150 else 1151 -- Suspend the task if the state is False. Otherwise, the task 1152 -- continues its execution, and the state of the suspension object 1153 -- is set to False (ARM D.10 par. 9). 1154 1155 if S.State then 1156 S.State := False; 1157 else 1158 S.Waiting := True; 1159 1160 loop 1161 -- Loop in case pthread_cond_wait returns earlier than expected 1162 -- (e.g. in case of EINTR caused by a signal). 1163 1164 Result := pthread_cond_wait (S.CV'Access, S.L'Access); 1165 pragma Assert (Result = 0 or else Result = EINTR); 1166 1167 exit when not S.Waiting; 1168 end loop; 1169 end if; 1170 1171 Result := pthread_mutex_unlock (S.L'Access); 1172 pragma Assert (Result = 0); 1173 1174 SSL.Abort_Undefer.all; 1175 end if; 1176 end Suspend_Until_True; 1177 1178 ---------------- 1179 -- Check_Exit -- 1180 ---------------- 1181 1182 -- Dummy version 1183 1184 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is 1185 pragma Unreferenced (Self_ID); 1186 begin 1187 return True; 1188 end Check_Exit; 1189 1190 -------------------- 1191 -- Check_No_Locks -- 1192 -------------------- 1193 1194 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is 1195 pragma Unreferenced (Self_ID); 1196 begin 1197 return True; 1198 end Check_No_Locks; 1199 1200 ---------------------- 1201 -- Environment_Task -- 1202 ---------------------- 1203 1204 function Environment_Task return Task_Id is 1205 begin 1206 return Environment_Task_Id; 1207 end Environment_Task; 1208 1209 -------------- 1210 -- Lock_RTS -- 1211 -------------- 1212 1213 procedure Lock_RTS is 1214 begin 1215 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1216 end Lock_RTS; 1217 1218 ---------------- 1219 -- Unlock_RTS -- 1220 ---------------- 1221 1222 procedure Unlock_RTS is 1223 begin 1224 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1225 end Unlock_RTS; 1226 1227 ------------------ 1228 -- Suspend_Task -- 1229 ------------------ 1230 1231 function Suspend_Task 1232 (T : ST.Task_Id; 1233 Thread_Self : Thread_Id) return Boolean 1234 is 1235 pragma Unreferenced (T, Thread_Self); 1236 begin 1237 return False; 1238 end Suspend_Task; 1239 1240 ----------------- 1241 -- Resume_Task -- 1242 ----------------- 1243 1244 function Resume_Task 1245 (T : ST.Task_Id; 1246 Thread_Self : Thread_Id) return Boolean 1247 is 1248 pragma Unreferenced (T, Thread_Self); 1249 begin 1250 return False; 1251 end Resume_Task; 1252 1253 -------------------- 1254 -- Stop_All_Tasks -- 1255 -------------------- 1256 1257 procedure Stop_All_Tasks is 1258 begin 1259 null; 1260 end Stop_All_Tasks; 1261 1262 --------------- 1263 -- Stop_Task -- 1264 --------------- 1265 1266 function Stop_Task (T : ST.Task_Id) return Boolean is 1267 pragma Unreferenced (T); 1268 begin 1269 return False; 1270 end Stop_Task; 1271 1272 ------------------- 1273 -- Continue_Task -- 1274 ------------------- 1275 1276 function Continue_Task (T : ST.Task_Id) return Boolean is 1277 pragma Unreferenced (T); 1278 begin 1279 return False; 1280 end Continue_Task; 1281 1282 ---------------- 1283 -- Initialize -- 1284 ---------------- 1285 1286 procedure Initialize (Environment_Task : Task_Id) is 1287 act : aliased struct_sigaction; 1288 old_act : aliased struct_sigaction; 1289 Tmp_Set : aliased sigset_t; 1290 Result : Interfaces.C.int; 1291 1292 function State 1293 (Int : System.Interrupt_Management.Interrupt_ID) return Character; 1294 pragma Import (C, State, "__gnat_get_interrupt_state"); 1295 -- Get interrupt state. Defined in a-init.c 1296 -- The input argument is the interrupt number, 1297 -- and the result is one of the following: 1298 1299 Default : constant Character := 's'; 1300 -- 'n' this interrupt not set by any Interrupt_State pragma 1301 -- 'u' Interrupt_State pragma set state to User 1302 -- 'r' Interrupt_State pragma set state to Runtime 1303 -- 's' Interrupt_State pragma set state to System (use "default" 1304 -- system handler) 1305 1306 begin 1307 Environment_Task_Id := Environment_Task; 1308 1309 Interrupt_Management.Initialize; 1310 1311 -- Prepare the set of signals that should unblocked in all tasks 1312 1313 Result := sigemptyset (Unblocked_Signal_Mask'Access); 1314 pragma Assert (Result = 0); 1315 1316 for J in Interrupt_Management.Interrupt_ID loop 1317 if System.Interrupt_Management.Keep_Unmasked (J) then 1318 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); 1319 pragma Assert (Result = 0); 1320 end if; 1321 end loop; 1322 1323 -- Initialize the lock used to synchronize chain of all ATCBs 1324 1325 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1326 1327 Specific.Initialize (Environment_Task); 1328 1329 if Use_Alternate_Stack then 1330 Environment_Task.Common.Task_Alternate_Stack := 1331 Alternate_Stack'Address; 1332 end if; 1333 1334 -- Make environment task known here because it doesn't go through 1335 -- Activate_Tasks, which does it for all other tasks. 1336 1337 Known_Tasks (Known_Tasks'First) := Environment_Task; 1338 Environment_Task.Known_Tasks_Index := Known_Tasks'First; 1339 1340 Enter_Task (Environment_Task); 1341 1342 if State 1343 (System.Interrupt_Management.Abort_Task_Interrupt) /= Default 1344 then 1345 act.sa_flags := 0; 1346 act.sa_handler := Abort_Handler'Address; 1347 1348 Result := sigemptyset (Tmp_Set'Access); 1349 pragma Assert (Result = 0); 1350 act.sa_mask := Tmp_Set; 1351 1352 Result := 1353 sigaction 1354 (Signal (System.Interrupt_Management.Abort_Task_Interrupt), 1355 act'Unchecked_Access, 1356 old_act'Unchecked_Access); 1357 pragma Assert (Result = 0); 1358 Abort_Handler_Installed := True; 1359 end if; 1360 end Initialize; 1361 1362 ----------------------- 1363 -- Set_Task_Affinity -- 1364 ----------------------- 1365 1366 procedure Set_Task_Affinity (T : ST.Task_Id) is 1367 pragma Unreferenced (T); 1368 1369 begin 1370 -- Setting task affinity is not supported by the underlying system 1371 1372 null; 1373 end Set_Task_Affinity; 1374 1375end System.Task_Primitives.Operations; 1376