1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- 10-- -- 11-- GNARL is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is a HP-UX DCE threads (HPUX 10) version of this package 33 34-- This package contains all the GNULL primitives that interface directly with 35-- the underlying OS. 36 37pragma Polling (Off); 38-- Turn off polling, we do not want ATC polling to take place during tasking 39-- operations. It causes infinite loops and other problems. 40 41with Ada.Unchecked_Conversion; 42 43with Interfaces.C; 44 45with System.Tasking.Debug; 46with System.Interrupt_Management; 47with System.OS_Constants; 48with System.OS_Primitives; 49with System.Task_Primitives.Interrupt_Operations; 50 51pragma Warnings (Off); 52with System.Interrupt_Management.Operations; 53pragma Elaborate_All (System.Interrupt_Management.Operations); 54pragma Warnings (On); 55 56with System.Soft_Links; 57-- We use System.Soft_Links instead of System.Tasking.Initialization 58-- because the later is a higher level package that we shouldn't depend on. 59-- For example when using the restricted run time, it is replaced by 60-- System.Tasking.Restricted.Stages. 61 62package body System.Task_Primitives.Operations is 63 64 package OSC renames System.OS_Constants; 65 package SSL renames System.Soft_Links; 66 67 use System.Tasking.Debug; 68 use System.Tasking; 69 use Interfaces.C; 70 use System.OS_Interface; 71 use System.Parameters; 72 use System.OS_Primitives; 73 74 package PIO renames System.Task_Primitives.Interrupt_Operations; 75 76 ---------------- 77 -- Local Data -- 78 ---------------- 79 80 -- The followings are logically constants, but need to be initialized 81 -- at run time. 82 83 Single_RTS_Lock : aliased RTS_Lock; 84 -- This is a lock to allow only one thread of control in the RTS at 85 -- a time; it is used to execute in mutual exclusion from all other tasks. 86 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List 87 88 Environment_Task_Id : Task_Id; 89 -- A variable to hold Task_Id for the environment task 90 91 Unblocked_Signal_Mask : aliased sigset_t; 92 -- The set of signals that should unblocked in all tasks 93 94 Time_Slice_Val : Integer; 95 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); 96 97 Dispatching_Policy : Character; 98 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); 99 100 -- Note: the reason that Locking_Policy is not needed is that this 101 -- is not implemented for DCE threads. The HPUX 10 port is at this 102 -- stage considered dead, and no further work is planned on it. 103 104 Foreign_Task_Elaborated : aliased Boolean := True; 105 -- Used to identified fake tasks (i.e., non-Ada Threads) 106 107 -------------------- 108 -- Local Packages -- 109 -------------------- 110 111 package Specific is 112 113 procedure Initialize (Environment_Task : Task_Id); 114 pragma Inline (Initialize); 115 -- Initialize various data needed by this package 116 117 function Is_Valid_Task return Boolean; 118 pragma Inline (Is_Valid_Task); 119 -- Does the executing thread have a TCB? 120 121 procedure Set (Self_Id : Task_Id); 122 pragma Inline (Set); 123 -- Set the self id for the current task 124 125 function Self return Task_Id; 126 pragma Inline (Self); 127 -- Return a pointer to the Ada Task Control Block of the calling task 128 129 end Specific; 130 131 package body Specific is separate; 132 -- The body of this package is target specific 133 134 ---------------------------------- 135 -- ATCB allocation/deallocation -- 136 ---------------------------------- 137 138 package body ATCB_Allocation is separate; 139 -- The body of this package is shared across several targets 140 141 --------------------------------- 142 -- Support for foreign threads -- 143 --------------------------------- 144 145 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; 146 -- Allocate and Initialize a new ATCB for the current Thread 147 148 function Register_Foreign_Thread 149 (Thread : Thread_Id) return Task_Id is separate; 150 151 ----------------------- 152 -- Local Subprograms -- 153 ----------------------- 154 155 procedure Abort_Handler (Sig : Signal); 156 157 function To_Address is 158 new Ada.Unchecked_Conversion (Task_Id, System.Address); 159 160 ------------------- 161 -- Abort_Handler -- 162 ------------------- 163 164 procedure Abort_Handler (Sig : Signal) is 165 pragma Unreferenced (Sig); 166 167 Self_Id : constant Task_Id := Self; 168 Result : Interfaces.C.int; 169 Old_Set : aliased sigset_t; 170 171 begin 172 if Self_Id.Deferral_Level = 0 173 and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level 174 and then not Self_Id.Aborting 175 then 176 Self_Id.Aborting := True; 177 178 -- Make sure signals used for RTS internal purpose are unmasked 179 180 Result := 181 pthread_sigmask 182 (SIG_UNBLOCK, 183 Unblocked_Signal_Mask'Access, 184 Old_Set'Access); 185 pragma Assert (Result = 0); 186 187 raise Standard'Abort_Signal; 188 end if; 189 end Abort_Handler; 190 191 ----------------- 192 -- Stack_Guard -- 193 ----------------- 194 195 -- The underlying thread system sets a guard page at the bottom of a thread 196 -- stack, so nothing is needed. 197 -- ??? Check the comment above 198 199 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is 200 pragma Unreferenced (T, On); 201 begin 202 null; 203 end Stack_Guard; 204 205 ------------------- 206 -- Get_Thread_Id -- 207 ------------------- 208 209 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is 210 begin 211 return T.Common.LL.Thread; 212 end Get_Thread_Id; 213 214 ---------- 215 -- Self -- 216 ---------- 217 218 function Self return Task_Id renames Specific.Self; 219 220 --------------------- 221 -- Initialize_Lock -- 222 --------------------- 223 224 -- Note: mutexes and cond_variables needed per-task basis are initialized 225 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such 226 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any 227 -- status change of RTS. Therefore raising Storage_Error in the following 228 -- routines should be able to be handled safely. 229 230 procedure Initialize_Lock 231 (Prio : System.Any_Priority; 232 L : not null access Lock) 233 is 234 Attributes : aliased pthread_mutexattr_t; 235 Result : Interfaces.C.int; 236 237 begin 238 Result := pthread_mutexattr_init (Attributes'Access); 239 pragma Assert (Result = 0 or else Result = ENOMEM); 240 241 if Result = ENOMEM then 242 raise Storage_Error; 243 end if; 244 245 L.Priority := Prio; 246 247 Result := pthread_mutex_init (L.L'Access, Attributes'Access); 248 pragma Assert (Result = 0 or else Result = ENOMEM); 249 250 if Result = ENOMEM then 251 raise Storage_Error; 252 end if; 253 254 Result := pthread_mutexattr_destroy (Attributes'Access); 255 pragma Assert (Result = 0); 256 end Initialize_Lock; 257 258 procedure Initialize_Lock 259 (L : not null access RTS_Lock; 260 Level : Lock_Level) 261 is 262 pragma Unreferenced (Level); 263 264 Attributes : aliased pthread_mutexattr_t; 265 Result : Interfaces.C.int; 266 267 begin 268 Result := pthread_mutexattr_init (Attributes'Access); 269 pragma Assert (Result = 0 or else Result = ENOMEM); 270 271 if Result = ENOMEM then 272 raise Storage_Error; 273 end if; 274 275 Result := pthread_mutex_init (L, Attributes'Access); 276 277 pragma Assert (Result = 0 or else Result = ENOMEM); 278 279 if Result = ENOMEM then 280 raise Storage_Error; 281 end if; 282 283 Result := pthread_mutexattr_destroy (Attributes'Access); 284 pragma Assert (Result = 0); 285 end Initialize_Lock; 286 287 ------------------- 288 -- Finalize_Lock -- 289 ------------------- 290 291 procedure Finalize_Lock (L : not null access Lock) is 292 Result : Interfaces.C.int; 293 begin 294 Result := pthread_mutex_destroy (L.L'Access); 295 pragma Assert (Result = 0); 296 end Finalize_Lock; 297 298 procedure Finalize_Lock (L : not null access RTS_Lock) is 299 Result : Interfaces.C.int; 300 begin 301 Result := pthread_mutex_destroy (L); 302 pragma Assert (Result = 0); 303 end Finalize_Lock; 304 305 ---------------- 306 -- Write_Lock -- 307 ---------------- 308 309 procedure Write_Lock 310 (L : not null access Lock; 311 Ceiling_Violation : out Boolean) 312 is 313 Result : Interfaces.C.int; 314 315 begin 316 L.Owner_Priority := Get_Priority (Self); 317 318 if L.Priority < L.Owner_Priority then 319 Ceiling_Violation := True; 320 return; 321 end if; 322 323 Result := pthread_mutex_lock (L.L'Access); 324 pragma Assert (Result = 0); 325 Ceiling_Violation := False; 326 end Write_Lock; 327 328 procedure Write_Lock 329 (L : not null access RTS_Lock; 330 Global_Lock : Boolean := False) 331 is 332 Result : Interfaces.C.int; 333 begin 334 if not Single_Lock or else Global_Lock then 335 Result := pthread_mutex_lock (L); 336 pragma Assert (Result = 0); 337 end if; 338 end Write_Lock; 339 340 procedure Write_Lock (T : Task_Id) is 341 Result : Interfaces.C.int; 342 begin 343 if not Single_Lock then 344 Result := pthread_mutex_lock (T.Common.LL.L'Access); 345 pragma Assert (Result = 0); 346 end if; 347 end Write_Lock; 348 349 --------------- 350 -- Read_Lock -- 351 --------------- 352 353 procedure Read_Lock 354 (L : not null access Lock; 355 Ceiling_Violation : out Boolean) 356 is 357 begin 358 Write_Lock (L, Ceiling_Violation); 359 end Read_Lock; 360 361 ------------ 362 -- Unlock -- 363 ------------ 364 365 procedure Unlock (L : not null access Lock) is 366 Result : Interfaces.C.int; 367 begin 368 Result := pthread_mutex_unlock (L.L'Access); 369 pragma Assert (Result = 0); 370 end Unlock; 371 372 procedure Unlock 373 (L : not null access RTS_Lock; 374 Global_Lock : Boolean := False) 375 is 376 Result : Interfaces.C.int; 377 begin 378 if not Single_Lock or else Global_Lock then 379 Result := pthread_mutex_unlock (L); 380 pragma Assert (Result = 0); 381 end if; 382 end Unlock; 383 384 procedure Unlock (T : Task_Id) is 385 Result : Interfaces.C.int; 386 begin 387 if not Single_Lock then 388 Result := pthread_mutex_unlock (T.Common.LL.L'Access); 389 pragma Assert (Result = 0); 390 end if; 391 end Unlock; 392 393 ----------------- 394 -- Set_Ceiling -- 395 ----------------- 396 397 -- Dynamic priority ceilings are not supported by the underlying system 398 399 procedure Set_Ceiling 400 (L : not null access Lock; 401 Prio : System.Any_Priority) 402 is 403 pragma Unreferenced (L, Prio); 404 begin 405 null; 406 end Set_Ceiling; 407 408 ----------- 409 -- Sleep -- 410 ----------- 411 412 procedure Sleep 413 (Self_ID : Task_Id; 414 Reason : System.Tasking.Task_States) 415 is 416 pragma Unreferenced (Reason); 417 418 Result : Interfaces.C.int; 419 420 begin 421 Result := 422 pthread_cond_wait 423 (cond => Self_ID.Common.LL.CV'Access, 424 mutex => (if Single_Lock 425 then Single_RTS_Lock'Access 426 else Self_ID.Common.LL.L'Access)); 427 428 -- EINTR is not considered a failure 429 430 pragma Assert (Result = 0 or else Result = EINTR); 431 end Sleep; 432 433 ----------------- 434 -- Timed_Sleep -- 435 ----------------- 436 437 procedure Timed_Sleep 438 (Self_ID : Task_Id; 439 Time : Duration; 440 Mode : ST.Delay_Modes; 441 Reason : System.Tasking.Task_States; 442 Timedout : out Boolean; 443 Yielded : out Boolean) 444 is 445 pragma Unreferenced (Reason); 446 447 Check_Time : constant Duration := Monotonic_Clock; 448 Abs_Time : Duration; 449 Request : aliased timespec; 450 Result : Interfaces.C.int; 451 452 begin 453 Timedout := True; 454 Yielded := False; 455 456 Abs_Time := 457 (if Mode = Relative 458 then Duration'Min (Time, Max_Sensible_Delay) + Check_Time 459 else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); 460 461 if Abs_Time > Check_Time then 462 Request := To_Timespec (Abs_Time); 463 464 loop 465 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 466 467 Result := 468 pthread_cond_timedwait 469 (cond => Self_ID.Common.LL.CV'Access, 470 mutex => (if Single_Lock 471 then Single_RTS_Lock'Access 472 else Self_ID.Common.LL.L'Access), 473 abstime => Request'Access); 474 475 exit when Abs_Time <= Monotonic_Clock; 476 477 if Result = 0 or Result = EINTR then 478 479 -- Somebody may have called Wakeup for us 480 481 Timedout := False; 482 exit; 483 end if; 484 485 pragma Assert (Result = ETIMEDOUT); 486 end loop; 487 end if; 488 end Timed_Sleep; 489 490 ----------------- 491 -- Timed_Delay -- 492 ----------------- 493 494 procedure Timed_Delay 495 (Self_ID : Task_Id; 496 Time : Duration; 497 Mode : ST.Delay_Modes) 498 is 499 Check_Time : constant Duration := Monotonic_Clock; 500 Abs_Time : Duration; 501 Request : aliased timespec; 502 503 Result : Interfaces.C.int; 504 pragma Warnings (Off, Result); 505 506 begin 507 if Single_Lock then 508 Lock_RTS; 509 end if; 510 511 Write_Lock (Self_ID); 512 513 Abs_Time := 514 (if Mode = Relative 515 then Time + Check_Time 516 else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); 517 518 if Abs_Time > Check_Time then 519 Request := To_Timespec (Abs_Time); 520 Self_ID.Common.State := Delay_Sleep; 521 522 loop 523 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 524 525 Result := 526 pthread_cond_timedwait 527 (cond => Self_ID.Common.LL.CV'Access, 528 mutex => (if Single_Lock 529 then Single_RTS_Lock'Access 530 else Self_ID.Common.LL.L'Access), 531 abstime => Request'Access); 532 533 exit when Abs_Time <= Monotonic_Clock; 534 535 pragma Assert (Result = 0 or else 536 Result = ETIMEDOUT or else 537 Result = EINTR); 538 end loop; 539 540 Self_ID.Common.State := Runnable; 541 end if; 542 543 Unlock (Self_ID); 544 545 if Single_Lock then 546 Unlock_RTS; 547 end if; 548 549 Result := sched_yield; 550 end Timed_Delay; 551 552 --------------------- 553 -- Monotonic_Clock -- 554 --------------------- 555 556 function Monotonic_Clock return Duration is 557 TS : aliased timespec; 558 Result : Interfaces.C.int; 559 begin 560 Result := Clock_Gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); 561 pragma Assert (Result = 0); 562 return To_Duration (TS); 563 end Monotonic_Clock; 564 565 ------------------- 566 -- RT_Resolution -- 567 ------------------- 568 569 function RT_Resolution return Duration is 570 begin 571 return 10#1.0#E-6; 572 end RT_Resolution; 573 574 ------------ 575 -- Wakeup -- 576 ------------ 577 578 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is 579 pragma Unreferenced (Reason); 580 Result : Interfaces.C.int; 581 begin 582 Result := pthread_cond_signal (T.Common.LL.CV'Access); 583 pragma Assert (Result = 0); 584 end Wakeup; 585 586 ----------- 587 -- Yield -- 588 ----------- 589 590 procedure Yield (Do_Yield : Boolean := True) is 591 Result : Interfaces.C.int; 592 pragma Unreferenced (Result); 593 begin 594 if Do_Yield then 595 Result := sched_yield; 596 end if; 597 end Yield; 598 599 ------------------ 600 -- Set_Priority -- 601 ------------------ 602 603 type Prio_Array_Type is array (System.Any_Priority) of Integer; 604 pragma Atomic_Components (Prio_Array_Type); 605 606 Prio_Array : Prio_Array_Type; 607 -- Global array containing the id of the currently running task for 608 -- each priority. 609 -- 610 -- Note: assume we are on single processor with run-til-blocked scheduling 611 612 procedure Set_Priority 613 (T : Task_Id; 614 Prio : System.Any_Priority; 615 Loss_Of_Inheritance : Boolean := False) 616 is 617 Result : Interfaces.C.int; 618 Array_Item : Integer; 619 Param : aliased struct_sched_param; 620 621 function Get_Policy (Prio : System.Any_Priority) return Character; 622 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); 623 -- Get priority specific dispatching policy 624 625 Priority_Specific_Policy : constant Character := Get_Policy (Prio); 626 -- Upper case first character of the policy name corresponding to the 627 -- task as set by a Priority_Specific_Dispatching pragma. 628 629 begin 630 Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); 631 632 if Dispatching_Policy = 'R' 633 or else Priority_Specific_Policy = 'R' 634 or else Time_Slice_Val > 0 635 then 636 Result := 637 pthread_setschedparam 638 (T.Common.LL.Thread, SCHED_RR, Param'Access); 639 640 elsif Dispatching_Policy = 'F' 641 or else Priority_Specific_Policy = 'F' 642 or else Time_Slice_Val = 0 643 then 644 Result := 645 pthread_setschedparam 646 (T.Common.LL.Thread, SCHED_FIFO, Param'Access); 647 648 else 649 Result := 650 pthread_setschedparam 651 (T.Common.LL.Thread, SCHED_OTHER, Param'Access); 652 end if; 653 654 pragma Assert (Result = 0); 655 656 if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then 657 658 -- Annex D requirement [RM D.2.2 par. 9]: 659 -- If the task drops its priority due to the loss of inherited 660 -- priority, it is added at the head of the ready queue for its 661 -- new active priority. 662 663 if Loss_Of_Inheritance 664 and then Prio < T.Common.Current_Priority 665 then 666 Array_Item := Prio_Array (T.Common.Base_Priority) + 1; 667 Prio_Array (T.Common.Base_Priority) := Array_Item; 668 669 loop 670 -- Let some processes a chance to arrive 671 672 Yield; 673 674 -- Then wait for our turn to proceed 675 676 exit when Array_Item = Prio_Array (T.Common.Base_Priority) 677 or else Prio_Array (T.Common.Base_Priority) = 1; 678 end loop; 679 680 Prio_Array (T.Common.Base_Priority) := 681 Prio_Array (T.Common.Base_Priority) - 1; 682 end if; 683 end if; 684 685 T.Common.Current_Priority := Prio; 686 end Set_Priority; 687 688 ------------------ 689 -- Get_Priority -- 690 ------------------ 691 692 function Get_Priority (T : Task_Id) return System.Any_Priority is 693 begin 694 return T.Common.Current_Priority; 695 end Get_Priority; 696 697 ---------------- 698 -- Enter_Task -- 699 ---------------- 700 701 procedure Enter_Task (Self_ID : Task_Id) is 702 begin 703 Self_ID.Common.LL.Thread := pthread_self; 704 Specific.Set (Self_ID); 705 end Enter_Task; 706 707 ------------------- 708 -- Is_Valid_Task -- 709 ------------------- 710 711 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 712 713 ----------------------------- 714 -- Register_Foreign_Thread -- 715 ----------------------------- 716 717 function Register_Foreign_Thread return Task_Id is 718 begin 719 if Is_Valid_Task then 720 return Self; 721 else 722 return Register_Foreign_Thread (pthread_self); 723 end if; 724 end Register_Foreign_Thread; 725 726 -------------------- 727 -- Initialize_TCB -- 728 -------------------- 729 730 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is 731 Mutex_Attr : aliased pthread_mutexattr_t; 732 Result : Interfaces.C.int; 733 Cond_Attr : aliased pthread_condattr_t; 734 735 begin 736 if not Single_Lock then 737 Result := pthread_mutexattr_init (Mutex_Attr'Access); 738 pragma Assert (Result = 0 or else Result = ENOMEM); 739 740 if Result = 0 then 741 Result := 742 pthread_mutex_init 743 (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); 744 pragma Assert (Result = 0 or else Result = ENOMEM); 745 end if; 746 747 if Result /= 0 then 748 Succeeded := False; 749 return; 750 end if; 751 752 Result := pthread_mutexattr_destroy (Mutex_Attr'Access); 753 pragma Assert (Result = 0); 754 end if; 755 756 Result := pthread_condattr_init (Cond_Attr'Access); 757 pragma Assert (Result = 0 or else Result = ENOMEM); 758 759 if Result = 0 then 760 Result := 761 pthread_cond_init 762 (Self_ID.Common.LL.CV'Access, 763 Cond_Attr'Access); 764 pragma Assert (Result = 0 or else Result = ENOMEM); 765 end if; 766 767 if Result = 0 then 768 Succeeded := True; 769 else 770 if not Single_Lock then 771 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); 772 pragma Assert (Result = 0); 773 end if; 774 775 Succeeded := False; 776 end if; 777 778 Result := pthread_condattr_destroy (Cond_Attr'Access); 779 pragma Assert (Result = 0); 780 end Initialize_TCB; 781 782 ----------------- 783 -- Create_Task -- 784 ----------------- 785 786 procedure Create_Task 787 (T : Task_Id; 788 Wrapper : System.Address; 789 Stack_Size : System.Parameters.Size_Type; 790 Priority : System.Any_Priority; 791 Succeeded : out Boolean) 792 is 793 Attributes : aliased pthread_attr_t; 794 Result : Interfaces.C.int; 795 796 function Thread_Body_Access is new 797 Ada.Unchecked_Conversion (System.Address, Thread_Body); 798 799 begin 800 Result := pthread_attr_init (Attributes'Access); 801 pragma Assert (Result = 0 or else Result = ENOMEM); 802 803 if Result /= 0 then 804 Succeeded := False; 805 return; 806 end if; 807 808 Result := pthread_attr_setstacksize 809 (Attributes'Access, Interfaces.C.size_t (Stack_Size)); 810 pragma Assert (Result = 0); 811 812 -- Since the initial signal mask of a thread is inherited from the 813 -- creator, and the Environment task has all its signals masked, we 814 -- do not need to manipulate caller's signal mask at this point. 815 -- All tasks in RTS will have All_Tasks_Mask initially. 816 817 Result := pthread_create 818 (T.Common.LL.Thread'Access, 819 Attributes'Access, 820 Thread_Body_Access (Wrapper), 821 To_Address (T)); 822 pragma Assert (Result = 0 or else Result = EAGAIN); 823 824 Succeeded := Result = 0; 825 826 pthread_detach (T.Common.LL.Thread'Access); 827 -- Detach the thread using pthread_detach, since DCE threads do not have 828 -- pthread_attr_set_detachstate. 829 830 Result := pthread_attr_destroy (Attributes'Access); 831 pragma Assert (Result = 0); 832 833 Set_Priority (T, Priority); 834 end Create_Task; 835 836 ------------------ 837 -- Finalize_TCB -- 838 ------------------ 839 840 procedure Finalize_TCB (T : Task_Id) is 841 Result : Interfaces.C.int; 842 843 begin 844 if not Single_Lock then 845 Result := pthread_mutex_destroy (T.Common.LL.L'Access); 846 pragma Assert (Result = 0); 847 end if; 848 849 Result := pthread_cond_destroy (T.Common.LL.CV'Access); 850 pragma Assert (Result = 0); 851 852 if T.Known_Tasks_Index /= -1 then 853 Known_Tasks (T.Known_Tasks_Index) := null; 854 end if; 855 856 ATCB_Allocation.Free_ATCB (T); 857 end Finalize_TCB; 858 859 --------------- 860 -- Exit_Task -- 861 --------------- 862 863 procedure Exit_Task is 864 begin 865 Specific.Set (null); 866 end Exit_Task; 867 868 ---------------- 869 -- Abort_Task -- 870 ---------------- 871 872 procedure Abort_Task (T : Task_Id) is 873 begin 874 -- Interrupt Server_Tasks may be waiting on an "event" flag (signal) 875 876 if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then 877 System.Interrupt_Management.Operations.Interrupt_Self_Process 878 (PIO.Get_Interrupt_ID (T)); 879 end if; 880 end Abort_Task; 881 882 ---------------- 883 -- Initialize -- 884 ---------------- 885 886 procedure Initialize (S : in out Suspension_Object) is 887 Mutex_Attr : aliased pthread_mutexattr_t; 888 Cond_Attr : aliased pthread_condattr_t; 889 Result : Interfaces.C.int; 890 begin 891 -- Initialize internal state (always to False (ARM D.10(6))) 892 893 S.State := False; 894 S.Waiting := False; 895 896 -- Initialize internal mutex 897 898 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); 899 pragma Assert (Result = 0 or else Result = ENOMEM); 900 901 if Result = ENOMEM then 902 raise Storage_Error; 903 end if; 904 905 -- Initialize internal condition variable 906 907 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); 908 pragma Assert (Result = 0 or else Result = ENOMEM); 909 910 if Result /= 0 then 911 Result := pthread_mutex_destroy (S.L'Access); 912 pragma Assert (Result = 0); 913 914 if Result = ENOMEM then 915 raise Storage_Error; 916 end if; 917 end if; 918 end Initialize; 919 920 -------------- 921 -- Finalize -- 922 -------------- 923 924 procedure Finalize (S : in out Suspension_Object) is 925 Result : Interfaces.C.int; 926 927 begin 928 -- Destroy internal mutex 929 930 Result := pthread_mutex_destroy (S.L'Access); 931 pragma Assert (Result = 0); 932 933 -- Destroy internal condition variable 934 935 Result := pthread_cond_destroy (S.CV'Access); 936 pragma Assert (Result = 0); 937 end Finalize; 938 939 ------------------- 940 -- Current_State -- 941 ------------------- 942 943 function Current_State (S : Suspension_Object) return Boolean is 944 begin 945 -- We do not want to use lock on this read operation. State is marked 946 -- as Atomic so that we ensure that the value retrieved is correct. 947 948 return S.State; 949 end Current_State; 950 951 --------------- 952 -- Set_False -- 953 --------------- 954 955 procedure Set_False (S : in out Suspension_Object) is 956 Result : Interfaces.C.int; 957 958 begin 959 SSL.Abort_Defer.all; 960 961 Result := pthread_mutex_lock (S.L'Access); 962 pragma Assert (Result = 0); 963 964 S.State := False; 965 966 Result := pthread_mutex_unlock (S.L'Access); 967 pragma Assert (Result = 0); 968 969 SSL.Abort_Undefer.all; 970 end Set_False; 971 972 -------------- 973 -- Set_True -- 974 -------------- 975 976 procedure Set_True (S : in out Suspension_Object) is 977 Result : Interfaces.C.int; 978 979 begin 980 SSL.Abort_Defer.all; 981 982 Result := pthread_mutex_lock (S.L'Access); 983 pragma Assert (Result = 0); 984 985 -- If there is already a task waiting on this suspension object then 986 -- we resume it, leaving the state of the suspension object to False, 987 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves 988 -- the state to True. 989 990 if S.Waiting then 991 S.Waiting := False; 992 S.State := False; 993 994 Result := pthread_cond_signal (S.CV'Access); 995 pragma Assert (Result = 0); 996 997 else 998 S.State := True; 999 end if; 1000 1001 Result := pthread_mutex_unlock (S.L'Access); 1002 pragma Assert (Result = 0); 1003 1004 SSL.Abort_Undefer.all; 1005 end Set_True; 1006 1007 ------------------------ 1008 -- Suspend_Until_True -- 1009 ------------------------ 1010 1011 procedure Suspend_Until_True (S : in out Suspension_Object) is 1012 Result : Interfaces.C.int; 1013 1014 begin 1015 SSL.Abort_Defer.all; 1016 1017 Result := pthread_mutex_lock (S.L'Access); 1018 pragma Assert (Result = 0); 1019 1020 if S.Waiting then 1021 -- Program_Error must be raised upon calling Suspend_Until_True 1022 -- if another task is already waiting on that suspension object 1023 -- (ARM D.10 par. 10). 1024 1025 Result := pthread_mutex_unlock (S.L'Access); 1026 pragma Assert (Result = 0); 1027 1028 SSL.Abort_Undefer.all; 1029 1030 raise Program_Error; 1031 else 1032 -- Suspend the task if the state is False. Otherwise, the task 1033 -- continues its execution, and the state of the suspension object 1034 -- is set to False (ARM D.10 par. 9). 1035 1036 if S.State then 1037 S.State := False; 1038 else 1039 S.Waiting := True; 1040 1041 loop 1042 -- Loop in case pthread_cond_wait returns earlier than expected 1043 -- (e.g. in case of EINTR caused by a signal). 1044 1045 Result := pthread_cond_wait (S.CV'Access, S.L'Access); 1046 pragma Assert (Result = 0 or else Result = EINTR); 1047 1048 exit when not S.Waiting; 1049 end loop; 1050 end if; 1051 1052 Result := pthread_mutex_unlock (S.L'Access); 1053 pragma Assert (Result = 0); 1054 1055 SSL.Abort_Undefer.all; 1056 end if; 1057 end Suspend_Until_True; 1058 1059 ---------------- 1060 -- Check_Exit -- 1061 ---------------- 1062 1063 -- Dummy version 1064 1065 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is 1066 pragma Unreferenced (Self_ID); 1067 begin 1068 return True; 1069 end Check_Exit; 1070 1071 -------------------- 1072 -- Check_No_Locks -- 1073 -------------------- 1074 1075 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is 1076 pragma Unreferenced (Self_ID); 1077 begin 1078 return True; 1079 end Check_No_Locks; 1080 1081 ---------------------- 1082 -- Environment_Task -- 1083 ---------------------- 1084 1085 function Environment_Task return Task_Id is 1086 begin 1087 return Environment_Task_Id; 1088 end Environment_Task; 1089 1090 -------------- 1091 -- Lock_RTS -- 1092 -------------- 1093 1094 procedure Lock_RTS is 1095 begin 1096 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1097 end Lock_RTS; 1098 1099 ---------------- 1100 -- Unlock_RTS -- 1101 ---------------- 1102 1103 procedure Unlock_RTS is 1104 begin 1105 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1106 end Unlock_RTS; 1107 1108 ------------------ 1109 -- Suspend_Task -- 1110 ------------------ 1111 1112 function Suspend_Task 1113 (T : ST.Task_Id; 1114 Thread_Self : Thread_Id) return Boolean 1115 is 1116 pragma Unreferenced (T); 1117 pragma Unreferenced (Thread_Self); 1118 begin 1119 return False; 1120 end Suspend_Task; 1121 1122 ----------------- 1123 -- Resume_Task -- 1124 ----------------- 1125 1126 function Resume_Task 1127 (T : ST.Task_Id; 1128 Thread_Self : Thread_Id) return Boolean 1129 is 1130 pragma Unreferenced (T); 1131 pragma Unreferenced (Thread_Self); 1132 begin 1133 return False; 1134 end Resume_Task; 1135 1136 -------------------- 1137 -- Stop_All_Tasks -- 1138 -------------------- 1139 1140 procedure Stop_All_Tasks is 1141 begin 1142 null; 1143 end Stop_All_Tasks; 1144 1145 --------------- 1146 -- Stop_Task -- 1147 --------------- 1148 1149 function Stop_Task (T : ST.Task_Id) return Boolean is 1150 pragma Unreferenced (T); 1151 begin 1152 return False; 1153 end Stop_Task; 1154 1155 ------------------- 1156 -- Continue_Task -- 1157 ------------------- 1158 1159 function Continue_Task (T : ST.Task_Id) return Boolean is 1160 pragma Unreferenced (T); 1161 begin 1162 return False; 1163 end Continue_Task; 1164 1165 ---------------- 1166 -- Initialize -- 1167 ---------------- 1168 1169 procedure Initialize (Environment_Task : Task_Id) is 1170 act : aliased struct_sigaction; 1171 old_act : aliased struct_sigaction; 1172 Tmp_Set : aliased sigset_t; 1173 Result : Interfaces.C.int; 1174 1175 function State 1176 (Int : System.Interrupt_Management.Interrupt_ID) return Character; 1177 pragma Import (C, State, "__gnat_get_interrupt_state"); 1178 -- Get interrupt state. Defined in a-init.c. The input argument is 1179 -- the interrupt number, and the result is one of the following: 1180 1181 Default : constant Character := 's'; 1182 -- 'n' this interrupt not set by any Interrupt_State pragma 1183 -- 'u' Interrupt_State pragma set state to User 1184 -- 'r' Interrupt_State pragma set state to Runtime 1185 -- 's' Interrupt_State pragma set state to System (use "default" 1186 -- system handler) 1187 1188 begin 1189 Environment_Task_Id := Environment_Task; 1190 1191 Interrupt_Management.Initialize; 1192 1193 -- Initialize the lock used to synchronize chain of all ATCBs 1194 1195 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1196 1197 Specific.Initialize (Environment_Task); 1198 1199 -- Make environment task known here because it doesn't go through 1200 -- Activate_Tasks, which does it for all other tasks. 1201 1202 Known_Tasks (Known_Tasks'First) := Environment_Task; 1203 Environment_Task.Known_Tasks_Index := Known_Tasks'First; 1204 1205 Enter_Task (Environment_Task); 1206 1207 -- Install the abort-signal handler 1208 1209 if State (System.Interrupt_Management.Abort_Task_Interrupt) 1210 /= Default 1211 then 1212 act.sa_flags := 0; 1213 act.sa_handler := Abort_Handler'Address; 1214 1215 Result := sigemptyset (Tmp_Set'Access); 1216 pragma Assert (Result = 0); 1217 act.sa_mask := Tmp_Set; 1218 1219 Result := 1220 sigaction ( 1221 Signal (System.Interrupt_Management.Abort_Task_Interrupt), 1222 act'Unchecked_Access, 1223 old_act'Unchecked_Access); 1224 pragma Assert (Result = 0); 1225 end if; 1226 end Initialize; 1227 1228 -- NOTE: Unlike other pthread implementations, we do *not* mask all 1229 -- signals here since we handle signals using the process-wide primitive 1230 -- signal, rather than using sigthreadmask and sigwait. The reason of 1231 -- this difference is that sigwait doesn't work when some critical 1232 -- signals (SIGABRT, SIGPIPE) are masked. 1233 1234 ----------------------- 1235 -- Set_Task_Affinity -- 1236 ----------------------- 1237 1238 procedure Set_Task_Affinity (T : ST.Task_Id) is 1239 pragma Unreferenced (T); 1240 1241 begin 1242 -- Setting task affinity is not supported by the underlying system 1243 1244 null; 1245 end Set_Task_Affinity; 1246 1247end System.Task_Primitives.Operations; 1248