1------------------------------------------------------------------------------ 2-- -- 3-- GNU ADA 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-2003, 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 2, or (at your option) any later ver- -- 14-- sion. GNARL 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNARL; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNARL was developed by the GNARL team at Florida State University. -- 30-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34-- This is a IRIX (pthread library) version of this package 35 36-- This package contains all the GNULL primitives that interface directly 37-- with the underlying OS. 38 39pragma Polling (Off); 40-- Turn off polling, we do not want ATC polling to take place during 41-- tasking operations. It causes infinite loops and other problems. 42 43with Interfaces.C; 44-- used for int 45-- size_t 46 47with System.Task_Info; 48 49with System.Tasking.Debug; 50-- used for Known_Tasks 51 52with System.IO; 53-- used for Put_Line 54 55with System.Interrupt_Management; 56-- used for Keep_Unmasked 57-- Abort_Task_Interrupt 58-- Interrupt_ID 59 60with System.Interrupt_Management.Operations; 61-- used for Set_Interrupt_Mask 62-- All_Tasks_Mask 63pragma Elaborate_All (System.Interrupt_Management.Operations); 64 65with System.Parameters; 66-- used for Size_Type 67 68with System.Tasking; 69-- used for Ada_Task_Control_Block 70-- Task_ID 71 72with System.Soft_Links; 73-- used for Defer/Undefer_Abort 74 75-- Note that we do not use System.Tasking.Initialization directly since 76-- this is a higher level package that we shouldn't depend on. For example 77-- when using the restricted run time, it is replaced by 78-- System.Tasking.Restricted.Initialization 79 80with System.Program_Info; 81-- used for Default_Task_Stack 82-- Default_Time_Slice 83-- Stack_Guard_Pages 84-- Pthread_Sched_Signal 85-- Pthread_Arena_Size 86 87with System.OS_Interface; 88-- used for various type, constant, and operations 89 90with System.OS_Primitives; 91-- used for Delay_Modes 92 93with Unchecked_Conversion; 94with Unchecked_Deallocation; 95 96package body System.Task_Primitives.Operations is 97 98 use System.Tasking; 99 use System.Tasking.Debug; 100 use Interfaces.C; 101 use System.OS_Interface; 102 use System.OS_Primitives; 103 use System.Parameters; 104 105 package SSL renames System.Soft_Links; 106 107 ------------------ 108 -- Local Data -- 109 ------------------ 110 111 -- The followings are logically constants, but need to be initialized 112 -- at run time. 113 114 Single_RTS_Lock : aliased RTS_Lock; 115 -- This is a lock to allow only one thread of control in the RTS at 116 -- a time; it is used to execute in mutual exclusion from all other tasks. 117 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List 118 119 ATCB_Key : aliased pthread_key_t; 120 -- Key used to find the Ada Task_ID associated with a thread 121 122 Environment_Task_ID : Task_ID; 123 -- A variable to hold Task_ID for the environment task. 124 125 Locking_Policy : Character; 126 pragma Import (C, Locking_Policy, "__gl_locking_policy"); 127 128 Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME; 129 130 Unblocked_Signal_Mask : aliased sigset_t; 131 132 Foreign_Task_Elaborated : aliased Boolean := True; 133 -- Used to identified fake tasks (i.e., non-Ada Threads). 134 135 -------------------- 136 -- Local Packages -- 137 -------------------- 138 139 package Specific is 140 141 procedure Initialize (Environment_Task : Task_ID); 142 pragma Inline (Initialize); 143 -- Initialize various data needed by this package. 144 145 function Is_Valid_Task return Boolean; 146 pragma Inline (Is_Valid_Task); 147 -- Does executing thread have a TCB? 148 149 procedure Set (Self_Id : Task_ID); 150 pragma Inline (Set); 151 -- Set the self id for the current task. 152 153 function Self return Task_ID; 154 pragma Inline (Self); 155 -- Return a pointer to the Ada Task Control Block of the calling task. 156 157 end Specific; 158 159 package body Specific is separate; 160 -- The body of this package is target specific. 161 162 --------------------------------- 163 -- Support for foreign threads -- 164 --------------------------------- 165 166 function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; 167 -- Allocate and Initialize a new ATCB for the current Thread. 168 169 function Register_Foreign_Thread 170 (Thread : Thread_Id) return Task_ID is separate; 171 172 ----------------------- 173 -- Local Subprograms -- 174 ----------------------- 175 176 function To_Address is new Unchecked_Conversion (Task_ID, System.Address); 177 178 procedure Abort_Handler (Sig : Signal); 179 -- Signal handler used to implement asynchronous abort. 180 181 ------------------- 182 -- Abort_Handler -- 183 ------------------- 184 185 procedure Abort_Handler (Sig : Signal) is 186 pragma Unreferenced (Sig); 187 188 T : constant Task_ID := Self; 189 Result : Interfaces.C.int; 190 Old_Set : aliased sigset_t; 191 192 begin 193 -- It is not safe to raise an exception when using ZCX and the GCC 194 -- exception handling mechanism. 195 196 if ZCX_By_Default and then GCC_ZCX_Support then 197 return; 198 end if; 199 200 if T.Deferral_Level = 0 201 and then T.Pending_ATC_Level < T.ATC_Nesting_Level 202 then 203 -- Make sure signals used for RTS internal purpose are unmasked 204 205 Result := pthread_sigmask 206 (SIG_UNBLOCK, 207 Unblocked_Signal_Mask'Unchecked_Access, 208 Old_Set'Unchecked_Access); 209 pragma Assert (Result = 0); 210 211 raise Standard'Abort_Signal; 212 end if; 213 end Abort_Handler; 214 215 ----------------- 216 -- Stack_Guard -- 217 ----------------- 218 219 -- The underlying thread system sets a guard page at the 220 -- bottom of a thread stack, so nothing is needed. 221 222 procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is 223 pragma Unreferenced (On); 224 pragma Unreferenced (T); 225 begin 226 null; 227 end Stack_Guard; 228 229 ------------------- 230 -- Get_Thread_Id -- 231 ------------------- 232 233 function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is 234 begin 235 return T.Common.LL.Thread; 236 end Get_Thread_Id; 237 238 ---------- 239 -- Self -- 240 ---------- 241 242 function Self return Task_ID renames Specific.Self; 243 244 --------------------- 245 -- Initialize_Lock -- 246 --------------------- 247 248 -- Note: mutexes and cond_variables needed per-task basis are 249 -- initialized in Initialize_TCB and the Storage_Error is 250 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) 251 -- used in RTS is initialized before any status change of RTS. 252 -- Therefore rasing Storage_Error in the following routines 253 -- should be able to be handled safely. 254 255 procedure Initialize_Lock 256 (Prio : System.Any_Priority; 257 L : access Lock) 258 is 259 Attributes : aliased pthread_mutexattr_t; 260 Result : Interfaces.C.int; 261 262 begin 263 Result := pthread_mutexattr_init (Attributes'Access); 264 pragma Assert (Result = 0 or else Result = ENOMEM); 265 266 if Result = ENOMEM then 267 raise Storage_Error; 268 end if; 269 270 if Locking_Policy = 'C' then 271 Result := pthread_mutexattr_setprotocol 272 (Attributes'Access, PTHREAD_PRIO_PROTECT); 273 pragma Assert (Result = 0); 274 275 Result := pthread_mutexattr_setprioceiling 276 (Attributes'Access, Interfaces.C.int (Prio)); 277 pragma Assert (Result = 0); 278 end if; 279 280 Result := pthread_mutex_init (L, Attributes'Access); 281 pragma Assert (Result = 0 or else Result = ENOMEM); 282 283 if Result = ENOMEM then 284 Result := pthread_mutexattr_destroy (Attributes'Access); 285 raise Storage_Error; 286 end if; 287 288 Result := pthread_mutexattr_destroy (Attributes'Access); 289 pragma Assert (Result = 0); 290 end Initialize_Lock; 291 292 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is 293 pragma Unreferenced (Level); 294 295 Attributes : aliased pthread_mutexattr_t; 296 Result : Interfaces.C.int; 297 298 begin 299 Result := pthread_mutexattr_init (Attributes'Access); 300 pragma Assert (Result = 0 or else Result = ENOMEM); 301 302 if Result = ENOMEM then 303 raise Storage_Error; 304 end if; 305 306 if Locking_Policy = 'C' then 307 Result := pthread_mutexattr_setprotocol 308 (Attributes'Access, PTHREAD_PRIO_PROTECT); 309 pragma Assert (Result = 0); 310 311 Result := pthread_mutexattr_setprioceiling 312 (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); 313 pragma Assert (Result = 0); 314 end if; 315 316 Result := pthread_mutex_init (L, Attributes'Access); 317 318 pragma Assert (Result = 0 or else Result = ENOMEM); 319 320 if Result = ENOMEM then 321 Result := pthread_mutexattr_destroy (Attributes'Access); 322 raise Storage_Error; 323 end if; 324 325 Result := pthread_mutexattr_destroy (Attributes'Access); 326 end Initialize_Lock; 327 328 ------------------- 329 -- Finalize_Lock -- 330 ------------------- 331 332 procedure Finalize_Lock (L : access Lock) is 333 Result : Interfaces.C.int; 334 begin 335 Result := pthread_mutex_destroy (L); 336 pragma Assert (Result = 0); 337 end Finalize_Lock; 338 339 procedure Finalize_Lock (L : access RTS_Lock) is 340 Result : Interfaces.C.int; 341 begin 342 Result := pthread_mutex_destroy (L); 343 pragma Assert (Result = 0); 344 end Finalize_Lock; 345 346 ---------------- 347 -- Write_Lock -- 348 ---------------- 349 350 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is 351 Result : Interfaces.C.int; 352 begin 353 Result := pthread_mutex_lock (L); 354 Ceiling_Violation := Result = EINVAL; 355 356 -- Assumes the cause of EINVAL is a priority ceiling violation 357 358 pragma Assert (Result = 0 or else Result = EINVAL); 359 end Write_Lock; 360 361 procedure Write_Lock 362 (L : access RTS_Lock; 363 Global_Lock : Boolean := False) 364 is 365 Result : Interfaces.C.int; 366 begin 367 if not Single_Lock or else Global_Lock then 368 Result := pthread_mutex_lock (L); 369 pragma Assert (Result = 0); 370 end if; 371 end Write_Lock; 372 373 procedure Write_Lock (T : Task_ID) is 374 Result : Interfaces.C.int; 375 begin 376 if not Single_Lock then 377 Result := pthread_mutex_lock (T.Common.LL.L'Access); 378 pragma Assert (Result = 0); 379 end if; 380 end Write_Lock; 381 382 --------------- 383 -- Read_Lock -- 384 --------------- 385 386 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is 387 begin 388 Write_Lock (L, Ceiling_Violation); 389 end Read_Lock; 390 391 ------------ 392 -- Unlock -- 393 ------------ 394 395 procedure Unlock (L : access Lock) is 396 Result : Interfaces.C.int; 397 begin 398 Result := pthread_mutex_unlock (L); 399 pragma Assert (Result = 0); 400 end Unlock; 401 402 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is 403 Result : Interfaces.C.int; 404 405 begin 406 if not Single_Lock or else Global_Lock then 407 Result := pthread_mutex_unlock (L); 408 pragma Assert (Result = 0); 409 end if; 410 end Unlock; 411 412 procedure Unlock (T : Task_ID) is 413 Result : Interfaces.C.int; 414 415 begin 416 if not Single_Lock then 417 Result := pthread_mutex_unlock (T.Common.LL.L'Access); 418 pragma Assert (Result = 0); 419 end if; 420 end Unlock; 421 422 ----------- 423 -- Sleep -- 424 ----------- 425 426 procedure Sleep 427 (Self_ID : ST.Task_ID; 428 Reason : System.Tasking.Task_States) 429 is 430 pragma Unreferenced (Reason); 431 432 Result : Interfaces.C.int; 433 434 begin 435 if Single_Lock then 436 Result := pthread_cond_wait 437 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); 438 else 439 Result := pthread_cond_wait 440 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); 441 end if; 442 443 -- EINTR is not considered a failure. 444 445 pragma Assert (Result = 0 or else Result = EINTR); 446 end Sleep; 447 448 ----------------- 449 -- Timed_Sleep -- 450 ----------------- 451 452 procedure Timed_Sleep 453 (Self_ID : Task_ID; 454 Time : Duration; 455 Mode : ST.Delay_Modes; 456 Reason : Task_States; 457 Timedout : out Boolean; 458 Yielded : out Boolean) 459 is 460 pragma Unreferenced (Reason); 461 462 Check_Time : constant Duration := Monotonic_Clock; 463 Abs_Time : Duration; 464 Request : aliased timespec; 465 Result : Interfaces.C.int; 466 467 begin 468 Timedout := True; 469 Yielded := False; 470 471 if Mode = Relative then 472 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; 473 else 474 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); 475 end if; 476 477 if Abs_Time > Check_Time then 478 Request := To_Timespec (Abs_Time); 479 480 loop 481 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 482 or else Self_ID.Pending_Priority_Change; 483 484 if Single_Lock then 485 Result := pthread_cond_timedwait 486 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, 487 Request'Access); 488 489 else 490 Result := pthread_cond_timedwait 491 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, 492 Request'Access); 493 end if; 494 495 exit when Abs_Time <= Monotonic_Clock; 496 497 if Result = 0 or else errno = EINTR then 498 Timedout := False; 499 exit; 500 end if; 501 end loop; 502 end if; 503 end Timed_Sleep; 504 505 ----------------- 506 -- Timed_Delay -- 507 ----------------- 508 509 -- This is for use in implementing delay statements, so 510 -- we assume the caller is abort-deferred but is holding 511 -- no locks. 512 513 procedure Timed_Delay 514 (Self_ID : Task_ID; 515 Time : Duration; 516 Mode : ST.Delay_Modes) 517 is 518 Check_Time : constant Duration := Monotonic_Clock; 519 Abs_Time : Duration; 520 Request : aliased timespec; 521 Result : Interfaces.C.int; 522 523 begin 524 -- Only the little window between deferring abort and 525 -- locking Self_ID is the reason we need to 526 -- check for pending abort and priority change below! :( 527 528 SSL.Abort_Defer.all; 529 530 if Single_Lock then 531 Lock_RTS; 532 end if; 533 534 Write_Lock (Self_ID); 535 536 if Mode = Relative then 537 Abs_Time := Time + Check_Time; 538 else 539 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); 540 end if; 541 542 if Abs_Time > Check_Time then 543 Request := To_Timespec (Abs_Time); 544 Self_ID.Common.State := Delay_Sleep; 545 546 loop 547 if Self_ID.Pending_Priority_Change then 548 Self_ID.Pending_Priority_Change := False; 549 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; 550 Set_Priority (Self_ID, Self_ID.Common.Base_Priority); 551 end if; 552 553 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 554 555 Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, 556 Self_ID.Common.LL.L'Access, Request'Access); 557 exit when Abs_Time <= Monotonic_Clock; 558 559 pragma Assert (Result = 0 560 or else Result = ETIMEDOUT 561 or else Result = EINTR); 562 end loop; 563 564 Self_ID.Common.State := Runnable; 565 end if; 566 567 Unlock (Self_ID); 568 569 if Single_Lock then 570 Unlock_RTS; 571 end if; 572 573 Yield; 574 SSL.Abort_Undefer.all; 575 end Timed_Delay; 576 577 --------------------- 578 -- Monotonic_Clock -- 579 --------------------- 580 581 function Monotonic_Clock return Duration is 582 TS : aliased timespec; 583 Result : Interfaces.C.int; 584 begin 585 Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access); 586 pragma Assert (Result = 0); 587 return To_Duration (TS); 588 end Monotonic_Clock; 589 590 ------------------- 591 -- RT_Resolution -- 592 ------------------- 593 594 function RT_Resolution return Duration is 595 begin 596 -- The clock_getres (Real_Time_Clock_Id) function appears to return 597 -- the interrupt resolution of the realtime clock and not the actual 598 -- resolution of reading the clock. Even though this last value is 599 -- only guaranteed to be 100 Hz, at least the Origin 200 appears to 600 -- have a microsecond resolution or better. 601 -- ??? We should figure out a method to return the right value on 602 -- all SGI hardware. 603 604 return 0.000_001; -- Assume microsecond resolution of clock 605 end RT_Resolution; 606 607 ------------ 608 -- Wakeup -- 609 ------------ 610 611 procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is 612 pragma Unreferenced (Reason); 613 Result : Interfaces.C.int; 614 begin 615 Result := pthread_cond_signal (T.Common.LL.CV'Access); 616 pragma Assert (Result = 0); 617 end Wakeup; 618 619 ----------- 620 -- Yield -- 621 ----------- 622 623 procedure Yield (Do_Yield : Boolean := True) is 624 Result : Interfaces.C.int; 625 pragma Unreferenced (Result); 626 begin 627 if Do_Yield then 628 Result := sched_yield; 629 end if; 630 end Yield; 631 632 ------------------ 633 -- Set_Priority -- 634 ------------------ 635 636 procedure Set_Priority 637 (T : Task_ID; 638 Prio : System.Any_Priority; 639 Loss_Of_Inheritance : Boolean := False) 640 is 641 pragma Unreferenced (Loss_Of_Inheritance); 642 643 Result : Interfaces.C.int; 644 Param : aliased struct_sched_param; 645 Sched_Policy : Interfaces.C.int; 646 647 use type System.Task_Info.Task_Info_Type; 648 649 function To_Int is new Unchecked_Conversion 650 (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); 651 652 begin 653 T.Common.Current_Priority := Prio; 654 Param.sched_priority := Interfaces.C.int (Prio); 655 656 if T.Common.Task_Info /= null then 657 Sched_Policy := To_Int (T.Common.Task_Info.Policy); 658 else 659 Sched_Policy := SCHED_FIFO; 660 end if; 661 662 Result := pthread_setschedparam (T.Common.LL.Thread, Sched_Policy, 663 Param'Access); 664 pragma Assert (Result = 0); 665 end Set_Priority; 666 667 ------------------ 668 -- Get_Priority -- 669 ------------------ 670 671 function Get_Priority (T : Task_ID) return System.Any_Priority is 672 begin 673 return T.Common.Current_Priority; 674 end Get_Priority; 675 676 ---------------- 677 -- Enter_Task -- 678 ---------------- 679 680 procedure Enter_Task (Self_ID : Task_ID) is 681 Result : Interfaces.C.int; 682 683 function To_Int is new Unchecked_Conversion 684 (System.Task_Info.CPU_Number, Interfaces.C.int); 685 686 use System.Task_Info; 687 688 begin 689 Self_ID.Common.LL.Thread := pthread_self; 690 Specific.Set (Self_ID); 691 692 if Self_ID.Common.Task_Info /= null 693 and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM 694 and then Self_ID.Common.Task_Info.Runon_CPU /= ANY_CPU 695 then 696 Result := pthread_setrunon_np 697 (To_Int (Self_ID.Common.Task_Info.Runon_CPU)); 698 pragma Assert (Result = 0); 699 end if; 700 701 Lock_RTS; 702 703 for J in Known_Tasks'Range loop 704 if Known_Tasks (J) = null then 705 Known_Tasks (J) := Self_ID; 706 Self_ID.Known_Tasks_Index := J; 707 exit; 708 end if; 709 end loop; 710 711 Unlock_RTS; 712 end Enter_Task; 713 714 -------------- 715 -- New_ATCB -- 716 -------------- 717 718 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is 719 begin 720 return new Ada_Task_Control_Block (Entry_Num); 721 end New_ATCB; 722 723 ------------------- 724 -- Is_Valid_Task -- 725 ------------------- 726 727 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 728 729 ----------------------------- 730 -- Register_Foreign_Thread -- 731 ----------------------------- 732 733 function Register_Foreign_Thread return Task_ID is 734 begin 735 if Is_Valid_Task then 736 return Self; 737 else 738 return Register_Foreign_Thread (pthread_self); 739 end if; 740 end Register_Foreign_Thread; 741 742 -------------------- 743 -- Initialize_TCB -- 744 -------------------- 745 746 procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is 747 Result : Interfaces.C.int; 748 Cond_Attr : aliased pthread_condattr_t; 749 750 begin 751 if not Single_Lock then 752 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); 753 end if; 754 755 Result := pthread_condattr_init (Cond_Attr'Access); 756 pragma Assert (Result = 0 or else Result = ENOMEM); 757 758 if Result = 0 then 759 Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, 760 Cond_Attr'Access); 761 pragma Assert (Result = 0 or else Result = ENOMEM); 762 end if; 763 764 if Result = 0 then 765 Succeeded := True; 766 else 767 if not Single_Lock then 768 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); 769 pragma Assert (Result = 0); 770 end if; 771 772 Succeeded := False; 773 end if; 774 775 Result := pthread_condattr_destroy (Cond_Attr'Access); 776 pragma Assert (Result = 0); 777 end Initialize_TCB; 778 779 ----------------- 780 -- Create_Task -- 781 ----------------- 782 783 procedure Create_Task 784 (T : Task_ID; 785 Wrapper : System.Address; 786 Stack_Size : System.Parameters.Size_Type; 787 Priority : System.Any_Priority; 788 Succeeded : out Boolean) 789 is 790 use System.Task_Info; 791 792 Attributes : aliased pthread_attr_t; 793 Sched_Param : aliased struct_sched_param; 794 Adjusted_Stack_Size : Interfaces.C.size_t; 795 Result : Interfaces.C.int; 796 797 function Thread_Body_Access is new 798 Unchecked_Conversion (System.Address, Thread_Body); 799 800 function To_Int is new Unchecked_Conversion 801 (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int); 802 function To_Int is new Unchecked_Conversion 803 (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int); 804 function To_Int is new Unchecked_Conversion 805 (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); 806 807 begin 808 if Stack_Size = System.Parameters.Unspecified_Size then 809 Adjusted_Stack_Size := 810 Interfaces.C.size_t (System.Program_Info.Default_Task_Stack); 811 812 elsif Stack_Size < Size_Type (Minimum_Stack_Size) then 813 Adjusted_Stack_Size := 814 Interfaces.C.size_t (Minimum_Stack_Size); 815 816 else 817 Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); 818 end if; 819 820 Result := pthread_attr_init (Attributes'Access); 821 pragma Assert (Result = 0 or else Result = ENOMEM); 822 823 if Result /= 0 then 824 Succeeded := False; 825 return; 826 end if; 827 828 Result := pthread_attr_setdetachstate 829 (Attributes'Access, PTHREAD_CREATE_DETACHED); 830 pragma Assert (Result = 0); 831 832 Result := pthread_attr_setstacksize 833 (Attributes'Access, Adjusted_Stack_Size); 834 pragma Assert (Result = 0); 835 836 if T.Common.Task_Info /= null then 837 Result := pthread_attr_setscope 838 (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); 839 pragma Assert (Result = 0); 840 841 Result := pthread_attr_setinheritsched 842 (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance)); 843 pragma Assert (Result = 0); 844 845 Result := pthread_attr_setschedpolicy 846 (Attributes'Access, To_Int (T.Common.Task_Info.Policy)); 847 pragma Assert (Result = 0); 848 849 Sched_Param.sched_priority := 850 Interfaces.C.int (T.Common.Task_Info.Priority); 851 852 Result := pthread_attr_setschedparam 853 (Attributes'Access, Sched_Param'Access); 854 pragma Assert (Result = 0); 855 end if; 856 857 -- Since the initial signal mask of a thread is inherited from the 858 -- creator, and the Environment task has all its signals masked, we 859 -- do not need to manipulate caller's signal mask at this point. 860 -- All tasks in RTS will have All_Tasks_Mask initially. 861 862 Result := pthread_create 863 (T.Common.LL.Thread'Access, 864 Attributes'Access, 865 Thread_Body_Access (Wrapper), 866 To_Address (T)); 867 868 if Result /= 0 869 and then T.Common.Task_Info /= null 870 and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM 871 then 872 -- The pthread_create call may have failed because we 873 -- asked for a system scope pthread and none were 874 -- available (probably because the program was not executed 875 -- by the superuser). Let's try for a process scope pthread 876 -- instead of raising Tasking_Error. 877 878 System.IO.Put_Line 879 ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task"); 880 System.IO.Put (""""); 881 System.IO.Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len)); 882 System.IO.Put_Line (""" could not be honored. "); 883 System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS"); 884 885 T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS; 886 Result := pthread_attr_setscope 887 (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); 888 pragma Assert (Result = 0); 889 890 Result := pthread_create 891 (T.Common.LL.Thread'Access, 892 Attributes'Access, 893 Thread_Body_Access (Wrapper), 894 To_Address (T)); 895 end if; 896 897 pragma Assert (Result = 0 or else Result = EAGAIN); 898 899 Succeeded := Result = 0; 900 901 -- The following needs significant commenting ??? 902 903 if T.Common.Task_Info /= null then 904 T.Common.Base_Priority := T.Common.Task_Info.Priority; 905 Set_Priority (T, T.Common.Task_Info.Priority); 906 else 907 Set_Priority (T, Priority); 908 end if; 909 910 Result := pthread_attr_destroy (Attributes'Access); 911 pragma Assert (Result = 0); 912 end Create_Task; 913 914 ------------------ 915 -- Finalize_TCB -- 916 ------------------ 917 918 procedure Finalize_TCB (T : Task_ID) is 919 Result : Interfaces.C.int; 920 Tmp : Task_ID := T; 921 Is_Self : constant Boolean := T = Self; 922 923 procedure Free is new 924 Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); 925 926 begin 927 if not Single_Lock then 928 Result := pthread_mutex_destroy (T.Common.LL.L'Access); 929 pragma Assert (Result = 0); 930 end if; 931 932 Result := pthread_cond_destroy (T.Common.LL.CV'Access); 933 pragma Assert (Result = 0); 934 935 if T.Known_Tasks_Index /= -1 then 936 Known_Tasks (T.Known_Tasks_Index) := null; 937 end if; 938 939 Free (Tmp); 940 941 if Is_Self then 942 Result := pthread_setspecific (ATCB_Key, System.Null_Address); 943 pragma Assert (Result = 0); 944 end if; 945 946 end Finalize_TCB; 947 948 --------------- 949 -- Exit_Task -- 950 --------------- 951 952 procedure Exit_Task is 953 begin 954 Specific.Set (null); 955 end Exit_Task; 956 957 ---------------- 958 -- Abort_Task -- 959 ---------------- 960 961 procedure Abort_Task (T : Task_ID) is 962 Result : Interfaces.C.int; 963 964 begin 965 Result := pthread_kill (T.Common.LL.Thread, 966 Signal (System.Interrupt_Management.Abort_Task_Interrupt)); 967 pragma Assert (Result = 0); 968 end Abort_Task; 969 970 ---------------- 971 -- Check_Exit -- 972 ---------------- 973 974 -- Dummy version 975 976 function Check_Exit (Self_ID : ST.Task_ID) return Boolean is 977 pragma Unreferenced (Self_ID); 978 979 begin 980 return True; 981 end Check_Exit; 982 983 -------------------- 984 -- Check_No_Locks -- 985 -------------------- 986 987 function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is 988 pragma Unreferenced (Self_ID); 989 990 begin 991 return True; 992 end Check_No_Locks; 993 994 ---------------------- 995 -- Environment_Task -- 996 ---------------------- 997 998 function Environment_Task return Task_ID is 999 begin 1000 return Environment_Task_ID; 1001 end Environment_Task; 1002 1003 -------------- 1004 -- Lock_RTS -- 1005 -------------- 1006 1007 procedure Lock_RTS is 1008 begin 1009 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1010 end Lock_RTS; 1011 1012 ---------------- 1013 -- Unlock_RTS -- 1014 ---------------- 1015 1016 procedure Unlock_RTS is 1017 begin 1018 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1019 end Unlock_RTS; 1020 1021 ------------------ 1022 -- Suspend_Task -- 1023 ------------------ 1024 1025 function Suspend_Task 1026 (T : ST.Task_ID; 1027 Thread_Self : Thread_Id) 1028 return Boolean 1029 is 1030 pragma Unreferenced (T); 1031 pragma Unreferenced (Thread_Self); 1032 1033 begin 1034 return False; 1035 end Suspend_Task; 1036 1037 ----------------- 1038 -- Resume_Task -- 1039 ----------------- 1040 1041 function Resume_Task 1042 (T : ST.Task_ID; 1043 Thread_Self : Thread_Id) 1044 return Boolean 1045 is 1046 pragma Unreferenced (T); 1047 pragma Unreferenced (Thread_Self); 1048 1049 begin 1050 return False; 1051 end Resume_Task; 1052 1053 ---------------- 1054 -- Initialize -- 1055 ---------------- 1056 1057 procedure Initialize (Environment_Task : Task_ID) is 1058 act : aliased struct_sigaction; 1059 old_act : aliased struct_sigaction; 1060 Tmp_Set : aliased sigset_t; 1061 Result : Interfaces.C.int; 1062 1063 function State (Int : System.Interrupt_Management.Interrupt_ID) 1064 return Character; 1065 pragma Import (C, State, "__gnat_get_interrupt_state"); 1066 -- Get interrupt state. Defined in a-init.c. The input argument is 1067 -- the interrupt number, and the result is one of the following: 1068 1069 Default : constant Character := 's'; 1070 -- 'n' this interrupt not set by any Interrupt_State pragma 1071 -- 'u' Interrupt_State pragma set state to User 1072 -- 'r' Interrupt_State pragma set state to Runtime 1073 -- 's' Interrupt_State pragma set state to System (use "default" 1074 -- system handler) 1075 1076 begin 1077 Environment_Task_ID := Environment_Task; 1078 1079 -- Initialize the lock used to synchronize chain of all ATCBs. 1080 1081 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1082 1083 Specific.Initialize (Environment_Task); 1084 1085 Enter_Task (Environment_Task); 1086 1087 -- Install the abort-signal handler 1088 1089 if State (System.Interrupt_Management.Abort_Task_Interrupt) 1090 /= Default 1091 then 1092 act.sa_flags := 0; 1093 act.sa_handler := Abort_Handler'Address; 1094 1095 Result := sigemptyset (Tmp_Set'Access); 1096 pragma Assert (Result = 0); 1097 act.sa_mask := Tmp_Set; 1098 1099 Result := 1100 sigaction ( 1101 Signal (System.Interrupt_Management.Abort_Task_Interrupt), 1102 act'Unchecked_Access, 1103 old_act'Unchecked_Access); 1104 pragma Assert (Result = 0); 1105 end if; 1106 end Initialize; 1107 1108begin 1109 declare 1110 Result : Interfaces.C.int; 1111 1112 begin 1113 -- Mask Environment task for all signals. The original mask of the 1114 -- Environment task will be recovered by Interrupt_Server task 1115 -- during the elaboration of s-interr.adb. 1116 1117 System.Interrupt_Management.Operations.Set_Interrupt_Mask 1118 (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); 1119 1120 -- Prepare the set of signals that should unblocked in all tasks 1121 1122 Result := sigemptyset (Unblocked_Signal_Mask'Access); 1123 pragma Assert (Result = 0); 1124 1125 for J in Interrupt_Management.Interrupt_ID loop 1126 if System.Interrupt_Management.Keep_Unmasked (J) then 1127 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); 1128 pragma Assert (Result = 0); 1129 end if; 1130 end loop; 1131 1132 -- Pick the highest resolution Clock for Clock_Realtime 1133 -- ??? This code currently doesn't work (see c94007[ab] for example) 1134 -- 1135 -- if syssgi (SGI_CYCLECNTR_SIZE) = 64 then 1136 -- Real_Time_Clock_Id := CLOCK_SGI_CYCLE; 1137 -- else 1138 -- Real_Time_Clock_Id := CLOCK_REALTIME; 1139 -- end if; 1140 end; 1141end System.Task_Primitives.Operations; 1142