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