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