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