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