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-2012, 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 OpenVMS/Alpha 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.OS_Primitives; 47with System.Soft_Links; 48with System.Aux_DEC; 49 50package body System.Task_Primitives.Operations is 51 52 use System.Tasking.Debug; 53 use System.Tasking; 54 use Interfaces.C; 55 use System.OS_Interface; 56 use System.Parameters; 57 use System.OS_Primitives; 58 use type System.OS_Primitives.OS_Time; 59 60 package SSL renames System.Soft_Links; 61 62 ---------------- 63 -- Local Data -- 64 ---------------- 65 66 -- The followings are logically constants, but need to be initialized 67 -- at run time. 68 69 Single_RTS_Lock : aliased RTS_Lock; 70 -- This is a lock to allow only one thread of control in the RTS at 71 -- a time; it is used to execute in mutual exclusion from all other tasks. 72 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List 73 74 ATCB_Key : aliased pthread_key_t; 75 -- Key used to find the Ada Task_Id associated with a thread 76 77 Environment_Task_Id : Task_Id; 78 -- A variable to hold Task_Id for the environment task 79 80 Time_Slice_Val : Integer; 81 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); 82 83 Dispatching_Policy : Character; 84 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); 85 86 Foreign_Task_Elaborated : aliased Boolean := True; 87 -- Used to identified fake tasks (i.e., non-Ada Threads) 88 89 -------------------- 90 -- Local Packages -- 91 -------------------- 92 93 package Specific is 94 95 procedure Initialize (Environment_Task : Task_Id); 96 pragma Inline (Initialize); 97 -- Initialize various data needed by this package 98 99 function Is_Valid_Task return Boolean; 100 pragma Inline (Is_Valid_Task); 101 -- Does executing thread have a TCB? 102 103 procedure Set (Self_Id : Task_Id); 104 pragma Inline (Set); 105 -- Set the self id for the current task 106 107 function Self return Task_Id; 108 pragma Inline (Self); 109 -- Return a pointer to the Ada Task Control Block of the calling task 110 111 end Specific; 112 113 package body Specific is separate; 114 -- The body of this package is target specific 115 116 ---------------------------------- 117 -- ATCB allocation/deallocation -- 118 ---------------------------------- 119 120 package body ATCB_Allocation is separate; 121 -- The body of this package is shared across several targets 122 123 --------------------------------- 124 -- Support for foreign threads -- 125 --------------------------------- 126 127 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; 128 -- Allocate and Initialize a new ATCB for the current Thread 129 130 function Register_Foreign_Thread 131 (Thread : Thread_Id) return Task_Id is separate; 132 133 ----------------------- 134 -- Local Subprograms -- 135 ----------------------- 136 137 function To_Task_Id is 138 new Ada.Unchecked_Conversion 139 (System.Task_Primitives.Task_Address, Task_Id); 140 141 function To_Address is 142 new Ada.Unchecked_Conversion 143 (Task_Id, System.Task_Primitives.Task_Address); 144 145 procedure Timer_Sleep_AST (ID : Address); 146 pragma Convention (C, Timer_Sleep_AST); 147 -- Signal the condition variable when AST fires 148 149 procedure Timer_Sleep_AST (ID : Address) is 150 Result : Interfaces.C.int; 151 pragma Warnings (Off, Result); 152 Self_ID : constant Task_Id := To_Task_Id (ID); 153 begin 154 Self_ID.Common.LL.AST_Pending := False; 155 Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access); 156 pragma Assert (Result = 0); 157 end Timer_Sleep_AST; 158 159 ----------------- 160 -- Stack_Guard -- 161 ----------------- 162 163 -- The underlying thread system sets a guard page at the bottom of a thread 164 -- stack, so nothing is needed. 165 -- ??? Check the comment above 166 167 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is 168 pragma Unreferenced (T); 169 pragma Unreferenced (On); 170 begin 171 null; 172 end Stack_Guard; 173 174 -------------------- 175 -- Get_Thread_Id -- 176 -------------------- 177 178 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is 179 begin 180 return T.Common.LL.Thread; 181 end Get_Thread_Id; 182 183 ---------- 184 -- Self -- 185 ---------- 186 187 function Self return Task_Id renames Specific.Self; 188 189 --------------------- 190 -- Initialize_Lock -- 191 --------------------- 192 193 -- Note: mutexes and cond_variables needed per-task basis are initialized 194 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such 195 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any 196 -- status change of RTS. Therefore raising Storage_Error in the following 197 -- routines should be able to be handled safely. 198 199 procedure Initialize_Lock 200 (Prio : System.Any_Priority; 201 L : not null access Lock) 202 is 203 Attributes : aliased pthread_mutexattr_t; 204 Result : Interfaces.C.int; 205 206 begin 207 Result := pthread_mutexattr_init (Attributes'Access); 208 pragma Assert (Result = 0 or else Result = ENOMEM); 209 210 if Result = ENOMEM then 211 raise Storage_Error; 212 end if; 213 214 L.Prio_Save := 0; 215 L.Prio := Interfaces.C.int (Prio); 216 217 Result := pthread_mutex_init (L.L'Access, Attributes'Access); 218 pragma Assert (Result = 0 or else Result = ENOMEM); 219 220 if Result = ENOMEM then 221 raise Storage_Error; 222 end if; 223 224 Result := pthread_mutexattr_destroy (Attributes'Access); 225 pragma Assert (Result = 0); 226 end Initialize_Lock; 227 228 procedure Initialize_Lock 229 (L : not null access RTS_Lock; 230 Level : Lock_Level) 231 is 232 pragma Unreferenced (Level); 233 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-- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes??? 246-- Result := pthread_mutexattr_settype_np 247-- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP); 248-- pragma Assert (Result = 0); 249 250-- Result := pthread_mutexattr_setprotocol 251-- (Attributes'Access, PTHREAD_PRIO_PROTECT); 252-- pragma Assert (Result = 0); 253 254-- Result := pthread_mutexattr_setprioceiling 255-- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); 256-- pragma Assert (Result = 0); 257 258 Result := pthread_mutex_init (L, Attributes'Access); 259 260 pragma Assert (Result = 0 or else Result = ENOMEM); 261 262 if Result = ENOMEM then 263 raise Storage_Error; 264 end if; 265 266 Result := pthread_mutexattr_destroy (Attributes'Access); 267 pragma Assert (Result = 0); 268 end Initialize_Lock; 269 270 ------------------- 271 -- Finalize_Lock -- 272 ------------------- 273 274 procedure Finalize_Lock (L : not null access Lock) is 275 Result : Interfaces.C.int; 276 begin 277 Result := pthread_mutex_destroy (L.L'Access); 278 pragma Assert (Result = 0); 279 end Finalize_Lock; 280 281 procedure Finalize_Lock (L : not null access RTS_Lock) is 282 Result : Interfaces.C.int; 283 begin 284 Result := pthread_mutex_destroy (L); 285 pragma Assert (Result = 0); 286 end Finalize_Lock; 287 288 ---------------- 289 -- Write_Lock -- 290 ---------------- 291 292 procedure Write_Lock 293 (L : not null access Lock; 294 Ceiling_Violation : out Boolean) 295 is 296 Self_ID : constant Task_Id := Self; 297 All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link; 298 Current_Prio : System.Any_Priority; 299 Result : Interfaces.C.int; 300 301 begin 302 Current_Prio := Get_Priority (Self_ID); 303 304 -- If there is no other tasks, no need to check priorities 305 306 if All_Tasks_Link /= Null_Task 307 and then L.Prio < Interfaces.C.int (Current_Prio) 308 then 309 Ceiling_Violation := True; 310 return; 311 end if; 312 313 Result := pthread_mutex_lock (L.L'Access); 314 pragma Assert (Result = 0); 315 316 Ceiling_Violation := False; 317-- Why is this commented out ??? 318-- L.Prio_Save := Interfaces.C.int (Current_Prio); 319-- Set_Priority (Self_ID, System.Any_Priority (L.Prio)); 320 end Write_Lock; 321 322 procedure Write_Lock 323 (L : not null access RTS_Lock; 324 Global_Lock : Boolean := False) 325 is 326 Result : Interfaces.C.int; 327 begin 328 if not Single_Lock or else Global_Lock then 329 Result := pthread_mutex_lock (L); 330 pragma Assert (Result = 0); 331 end if; 332 end Write_Lock; 333 334 procedure Write_Lock (T : Task_Id) is 335 Result : Interfaces.C.int; 336 begin 337 if not Single_Lock then 338 Result := pthread_mutex_lock (T.Common.LL.L'Access); 339 pragma Assert (Result = 0); 340 end if; 341 end Write_Lock; 342 343 --------------- 344 -- Read_Lock -- 345 --------------- 346 347 procedure Read_Lock 348 (L : not null access Lock; 349 Ceiling_Violation : out Boolean) 350 is 351 begin 352 Write_Lock (L, Ceiling_Violation); 353 end Read_Lock; 354 355 ------------ 356 -- Unlock -- 357 ------------ 358 359 procedure Unlock (L : not null access Lock) is 360 Result : Interfaces.C.int; 361 begin 362 Result := pthread_mutex_unlock (L.L'Access); 363 pragma Assert (Result = 0); 364 end Unlock; 365 366 procedure Unlock 367 (L : not null access RTS_Lock; 368 Global_Lock : Boolean := False) 369 is 370 Result : Interfaces.C.int; 371 begin 372 if not Single_Lock or else Global_Lock then 373 Result := pthread_mutex_unlock (L); 374 pragma Assert (Result = 0); 375 end if; 376 end Unlock; 377 378 procedure Unlock (T : Task_Id) is 379 Result : Interfaces.C.int; 380 begin 381 if not Single_Lock then 382 Result := pthread_mutex_unlock (T.Common.LL.L'Access); 383 pragma Assert (Result = 0); 384 end if; 385 end Unlock; 386 387 ----------------- 388 -- Set_Ceiling -- 389 ----------------- 390 391 -- Dynamic priority ceilings are not supported by the underlying system 392 393 procedure Set_Ceiling 394 (L : not null access Lock; 395 Prio : System.Any_Priority) 396 is 397 pragma Unreferenced (L, Prio); 398 begin 399 null; 400 end Set_Ceiling; 401 402 ----------- 403 -- Sleep -- 404 ----------- 405 406 procedure Sleep 407 (Self_ID : Task_Id; 408 Reason : System.Tasking.Task_States) 409 is 410 pragma Unreferenced (Reason); 411 Result : Interfaces.C.int; 412 413 begin 414 Result := 415 pthread_cond_wait 416 (cond => Self_ID.Common.LL.CV'Access, 417 mutex => (if Single_Lock 418 then Single_RTS_Lock'Access 419 else Self_ID.Common.LL.L'Access)); 420 421 -- EINTR is not considered a failure 422 423 pragma Assert (Result = 0 or else Result = EINTR); 424 425 if Self_ID.Deferral_Level = 0 426 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 427 then 428 Unlock (Self_ID); 429 raise Standard'Abort_Signal; 430 end if; 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 Sleep_Time : OS_Time; 448 Result : Interfaces.C.int; 449 Status : Cond_Value_Type; 450 451 -- The body below requires more comments ??? 452 453 begin 454 Timedout := False; 455 Yielded := False; 456 457 Sleep_Time := To_OS_Time (Time, Mode); 458 459 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then 460 return; 461 end if; 462 463 Self_ID.Common.LL.AST_Pending := True; 464 465 Sys_Setimr 466 (Status, 0, Sleep_Time, 467 Timer_Sleep_AST'Access, To_Address (Self_ID), 0); 468 469 if (Status and 1) /= 1 then 470 raise Storage_Error; 471 end if; 472 473 if Single_Lock then 474 Result := 475 pthread_cond_wait 476 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); 477 pragma Assert (Result = 0); 478 479 else 480 Result := 481 pthread_cond_wait 482 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); 483 pragma Assert (Result = 0); 484 end if; 485 486 Yielded := True; 487 488 if not Self_ID.Common.LL.AST_Pending then 489 Timedout := True; 490 else 491 Sys_Cantim (Status, To_Address (Self_ID), 0); 492 pragma Assert ((Status and 1) = 1); 493 end if; 494 end Timed_Sleep; 495 496 ----------------- 497 -- Timed_Delay -- 498 ----------------- 499 500 procedure Timed_Delay 501 (Self_ID : Task_Id; 502 Time : Duration; 503 Mode : ST.Delay_Modes) 504 is 505 Sleep_Time : OS_Time; 506 Result : Interfaces.C.int; 507 Status : Cond_Value_Type; 508 Yielded : Boolean := False; 509 510 begin 511 if Single_Lock then 512 Lock_RTS; 513 end if; 514 515 -- More comments required in body below ??? 516 517 Write_Lock (Self_ID); 518 519 if Time /= 0.0 or else Mode /= Relative then 520 Sleep_Time := To_OS_Time (Time, Mode); 521 522 if Mode = Relative or else OS_Clock <= Sleep_Time then 523 Self_ID.Common.State := Delay_Sleep; 524 Self_ID.Common.LL.AST_Pending := True; 525 526 Sys_Setimr 527 (Status, 0, Sleep_Time, 528 Timer_Sleep_AST'Access, To_Address (Self_ID), 0); 529 530 -- Comment following test 531 532 if (Status and 1) /= 1 then 533 raise Storage_Error; 534 end if; 535 536 loop 537 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then 538 Sys_Cantim (Status, To_Address (Self_ID), 0); 539 pragma Assert ((Status and 1) = 1); 540 exit; 541 end if; 542 543 Result := 544 pthread_cond_wait 545 (cond => Self_ID.Common.LL.CV'Access, 546 mutex => (if Single_Lock 547 then Single_RTS_Lock'Access 548 else Self_ID.Common.LL.L'Access)); 549 pragma Assert (Result = 0); 550 551 Yielded := True; 552 553 exit when not Self_ID.Common.LL.AST_Pending; 554 end loop; 555 556 Self_ID.Common.State := Runnable; 557 end if; 558 end if; 559 560 Unlock (Self_ID); 561 562 if Single_Lock then 563 Unlock_RTS; 564 end if; 565 566 if not Yielded then 567 Result := sched_yield; 568 pragma Assert (Result = 0); 569 end if; 570 end Timed_Delay; 571 572 --------------------- 573 -- Monotonic_Clock -- 574 --------------------- 575 576 function Monotonic_Clock return Duration 577 renames System.OS_Primitives.Monotonic_Clock; 578 579 ------------------- 580 -- RT_Resolution -- 581 ------------------- 582 583 function RT_Resolution return Duration is 584 begin 585 -- Document origin of this magic constant ??? 586 return 10#1.0#E-3; 587 end RT_Resolution; 588 589 ------------ 590 -- Wakeup -- 591 ------------ 592 593 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is 594 pragma Unreferenced (Reason); 595 Result : Interfaces.C.int; 596 begin 597 Result := pthread_cond_signal (T.Common.LL.CV'Access); 598 pragma Assert (Result = 0); 599 end Wakeup; 600 601 ----------- 602 -- Yield -- 603 ----------- 604 605 procedure Yield (Do_Yield : Boolean := True) is 606 Result : Interfaces.C.int; 607 pragma Unreferenced (Result); 608 begin 609 if Do_Yield then 610 Result := sched_yield; 611 end if; 612 end Yield; 613 614 ------------------ 615 -- Set_Priority -- 616 ------------------ 617 618 procedure Set_Priority 619 (T : Task_Id; 620 Prio : System.Any_Priority; 621 Loss_Of_Inheritance : Boolean := False) 622 is 623 pragma Unreferenced (Loss_Of_Inheritance); 624 625 Result : Interfaces.C.int; 626 Param : aliased struct_sched_param; 627 628 function Get_Policy (Prio : System.Any_Priority) return Character; 629 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); 630 -- Get priority specific dispatching policy 631 632 Priority_Specific_Policy : constant Character := Get_Policy (Prio); 633 -- Upper case first character of the policy name corresponding to the 634 -- task as set by a Priority_Specific_Dispatching pragma. 635 636 begin 637 T.Common.Current_Priority := Prio; 638 Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); 639 640 if Dispatching_Policy = 'R' 641 or else Priority_Specific_Policy = 'R' 642 or else Time_Slice_Val > 0 643 then 644 Result := 645 pthread_setschedparam 646 (T.Common.LL.Thread, SCHED_RR, Param'Access); 647 648 elsif Dispatching_Policy = 'F' 649 or else Priority_Specific_Policy = 'F' 650 or else Time_Slice_Val = 0 651 then 652 Result := 653 pthread_setschedparam 654 (T.Common.LL.Thread, SCHED_FIFO, Param'Access); 655 656 else 657 -- SCHED_OTHER priorities are restricted to the range 8 - 15. 658 -- Since the translation from Underlying priorities results 659 -- in a range of 16 - 31, dividing by 2 gives the correct result. 660 661 Param.sched_priority := Param.sched_priority / 2; 662 Result := 663 pthread_setschedparam 664 (T.Common.LL.Thread, SCHED_OTHER, Param'Access); 665 end if; 666 667 pragma Assert (Result = 0); 668 end Set_Priority; 669 670 ------------------ 671 -- Get_Priority -- 672 ------------------ 673 674 function Get_Priority (T : Task_Id) return System.Any_Priority is 675 begin 676 return T.Common.Current_Priority; 677 end Get_Priority; 678 679 ---------------- 680 -- Enter_Task -- 681 ---------------- 682 683 procedure Enter_Task (Self_ID : Task_Id) is 684 begin 685 Self_ID.Common.LL.Thread := pthread_self; 686 Specific.Set (Self_ID); 687 end Enter_Task; 688 689 ------------------- 690 -- Is_Valid_Task -- 691 ------------------- 692 693 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 694 695 ----------------------------- 696 -- Register_Foreign_Thread -- 697 ----------------------------- 698 699 function Register_Foreign_Thread return Task_Id is 700 begin 701 if Is_Valid_Task then 702 return Self; 703 else 704 return Register_Foreign_Thread (pthread_self); 705 end if; 706 end Register_Foreign_Thread; 707 708 -------------------- 709 -- Initialize_TCB -- 710 -------------------- 711 712 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is 713 Mutex_Attr : aliased pthread_mutexattr_t; 714 Result : Interfaces.C.int; 715 Cond_Attr : aliased pthread_condattr_t; 716 717 begin 718 -- More comments required in body below ??? 719 720 if not Single_Lock then 721 Result := pthread_mutexattr_init (Mutex_Attr'Access); 722 pragma Assert (Result = 0 or else Result = ENOMEM); 723 724 if Result = 0 then 725 Result := 726 pthread_mutex_init 727 (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); 728 pragma Assert (Result = 0 or else Result = ENOMEM); 729 end if; 730 731 if Result /= 0 then 732 Succeeded := False; 733 return; 734 end if; 735 736 Result := pthread_mutexattr_destroy (Mutex_Attr'Access); 737 pragma Assert (Result = 0); 738 end if; 739 740 Result := pthread_condattr_init (Cond_Attr'Access); 741 pragma Assert (Result = 0 or else Result = ENOMEM); 742 743 if Result = 0 then 744 Result := 745 pthread_cond_init 746 (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); 747 pragma Assert (Result = 0 or else Result = ENOMEM); 748 end if; 749 750 if Result = 0 then 751 Succeeded := True; 752 753 else 754 if not Single_Lock then 755 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); 756 pragma Assert (Result = 0); 757 end if; 758 759 Succeeded := False; 760 end if; 761 762 Result := pthread_condattr_destroy (Cond_Attr'Access); 763 pragma Assert (Result = 0); 764 end Initialize_TCB; 765 766 ----------------- 767 -- Create_Task -- 768 ----------------- 769 770 procedure Create_Task 771 (T : Task_Id; 772 Wrapper : System.Address; 773 Stack_Size : System.Parameters.Size_Type; 774 Priority : System.Any_Priority; 775 Succeeded : out Boolean) 776 is 777 Attributes : aliased pthread_attr_t; 778 Result : Interfaces.C.int; 779 780 function Thread_Body_Access is new 781 Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body); 782 783 Task_Name : String (1 .. System.Parameters.Max_Task_Image_Length + 1); 784 785 begin 786 -- Since the initial signal mask of a thread is inherited from the 787 -- creator, we need to set our local signal mask to mask all signals 788 -- during the creation operation, to make sure the new thread is 789 -- not disturbed by signals before it has set its own Task_Id. 790 791 Result := pthread_attr_init (Attributes'Access); 792 pragma Assert (Result = 0 or else Result = ENOMEM); 793 794 if Result /= 0 then 795 Succeeded := False; 796 return; 797 end if; 798 799 Result := pthread_attr_setdetachstate 800 (Attributes'Access, PTHREAD_CREATE_DETACHED); 801 pragma Assert (Result = 0); 802 803 Result := pthread_attr_setstacksize 804 (Attributes'Access, Interfaces.C.size_t (Stack_Size)); 805 pragma Assert (Result = 0); 806 807 -- This call may be unnecessary, not sure. ??? 808 809 Result := 810 pthread_attr_setinheritsched 811 (Attributes'Access, PTHREAD_EXPLICIT_SCHED); 812 pragma Assert (Result = 0); 813 814 if T.Common.Task_Image_Len > 0 then 815 816 -- Set thread name to ease debugging 817 818 Task_Name (1 .. T.Common.Task_Image_Len) := 819 T.Common.Task_Image (1 .. T.Common.Task_Image_Len); 820 Task_Name (T.Common.Task_Image_Len + 1) := ASCII.NUL; 821 822 Result := pthread_attr_setname_np 823 (Attributes'Access, Task_Name'Address, Null_Address); 824 pragma Assert (Result = 0); 825 end if; 826 827 -- Note: the use of Unrestricted_Access in the following call is needed 828 -- because otherwise we have an error of getting a access-to-volatile 829 -- value which points to a non-volatile object. But in this case it is 830 -- safe to do this, since we know we have no problems with aliasing and 831 -- Unrestricted_Access bypasses this check. 832 833 Result := 834 pthread_create 835 (T.Common.LL.Thread'Unrestricted_Access, 836 Attributes'Access, 837 Thread_Body_Access (Wrapper), 838 To_Address (T)); 839 840 -- ENOMEM is a valid run-time error -- do not shut down 841 842 pragma Assert (Result = 0 843 or else Result = EAGAIN or else Result = ENOMEM); 844 845 Succeeded := Result = 0; 846 847 Result := pthread_attr_destroy (Attributes'Access); 848 pragma Assert (Result = 0); 849 850 if Succeeded then 851 Set_Priority (T, Priority); 852 end if; 853 end Create_Task; 854 855 ------------------ 856 -- Finalize_TCB -- 857 ------------------ 858 859 procedure Finalize_TCB (T : Task_Id) is 860 Result : Interfaces.C.int; 861 862 begin 863 if not Single_Lock then 864 Result := pthread_mutex_destroy (T.Common.LL.L'Access); 865 pragma Assert (Result = 0); 866 end if; 867 868 Result := pthread_cond_destroy (T.Common.LL.CV'Access); 869 pragma Assert (Result = 0); 870 871 if T.Known_Tasks_Index /= -1 then 872 Known_Tasks (T.Known_Tasks_Index) := null; 873 end if; 874 875 ATCB_Allocation.Free_ATCB (T); 876 end Finalize_TCB; 877 878 --------------- 879 -- Exit_Task -- 880 --------------- 881 882 procedure Exit_Task is 883 begin 884 null; 885 end Exit_Task; 886 887 ---------------- 888 -- Abort_Task -- 889 ---------------- 890 891 procedure Abort_Task (T : Task_Id) is 892 begin 893 -- Interrupt Server_Tasks may be waiting on an event flag 894 895 if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then 896 Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag); 897 end if; 898 end Abort_Task; 899 900 ---------------- 901 -- Initialize -- 902 ---------------- 903 904 procedure Initialize (S : in out Suspension_Object) is 905 Mutex_Attr : aliased pthread_mutexattr_t; 906 Cond_Attr : aliased pthread_condattr_t; 907 Result : Interfaces.C.int; 908 begin 909 -- Initialize internal state (always to False (D.10 (6))) 910 911 S.State := False; 912 S.Waiting := False; 913 914 -- Initialize internal mutex 915 916 Result := pthread_mutexattr_init (Mutex_Attr'Access); 917 pragma Assert (Result = 0 or else Result = ENOMEM); 918 919 if Result = ENOMEM then 920 raise Storage_Error; 921 end if; 922 923 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); 924 pragma Assert (Result = 0 or else Result = ENOMEM); 925 926 if Result = ENOMEM then 927 Result := pthread_mutexattr_destroy (Mutex_Attr'Access); 928 pragma Assert (Result = 0); 929 930 raise Storage_Error; 931 end if; 932 933 Result := pthread_mutexattr_destroy (Mutex_Attr'Access); 934 pragma Assert (Result = 0); 935 936 -- Initialize internal condition variable 937 938 Result := pthread_condattr_init (Cond_Attr'Access); 939 pragma Assert (Result = 0 or else Result = ENOMEM); 940 941 if Result /= 0 then 942 Result := pthread_mutex_destroy (S.L'Access); 943 pragma Assert (Result = 0); 944 945 if Result = ENOMEM then 946 raise Storage_Error; 947 end if; 948 end if; 949 950 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); 951 pragma Assert (Result = 0 or else Result = ENOMEM); 952 953 if Result /= 0 then 954 Result := pthread_mutex_destroy (S.L'Access); 955 pragma Assert (Result = 0); 956 957 if Result = ENOMEM then 958 Result := pthread_condattr_destroy (Cond_Attr'Access); 959 pragma Assert (Result = 0); 960 961 raise Storage_Error; 962 end if; 963 end if; 964 965 Result := pthread_condattr_destroy (Cond_Attr'Access); 966 pragma Assert (Result = 0); 967 end Initialize; 968 969 -------------- 970 -- Finalize -- 971 -------------- 972 973 procedure Finalize (S : in out Suspension_Object) is 974 Result : Interfaces.C.int; 975 976 begin 977 -- Destroy internal mutex 978 979 Result := pthread_mutex_destroy (S.L'Access); 980 pragma Assert (Result = 0); 981 982 -- Destroy internal condition variable 983 984 Result := pthread_cond_destroy (S.CV'Access); 985 pragma Assert (Result = 0); 986 end Finalize; 987 988 ------------------- 989 -- Current_State -- 990 ------------------- 991 992 function Current_State (S : Suspension_Object) return Boolean is 993 begin 994 -- We do not want to use lock on this read operation. State is marked 995 -- as Atomic so that we ensure that the value retrieved is correct. 996 997 return S.State; 998 end Current_State; 999 1000 --------------- 1001 -- Set_False -- 1002 --------------- 1003 1004 procedure Set_False (S : in out Suspension_Object) is 1005 Result : Interfaces.C.int; 1006 1007 begin 1008 SSL.Abort_Defer.all; 1009 1010 Result := pthread_mutex_lock (S.L'Access); 1011 pragma Assert (Result = 0); 1012 1013 S.State := False; 1014 1015 Result := pthread_mutex_unlock (S.L'Access); 1016 pragma Assert (Result = 0); 1017 1018 SSL.Abort_Undefer.all; 1019 end Set_False; 1020 1021 -------------- 1022 -- Set_True -- 1023 -------------- 1024 1025 procedure Set_True (S : in out Suspension_Object) is 1026 Result : Interfaces.C.int; 1027 1028 begin 1029 SSL.Abort_Defer.all; 1030 1031 Result := pthread_mutex_lock (S.L'Access); 1032 pragma Assert (Result = 0); 1033 1034 -- If there is already a task waiting on this suspension object then 1035 -- we resume it, leaving the state of the suspension object to False, 1036 -- as specified in (RM D.10(9)), otherwise leave state set to True. 1037 1038 if S.Waiting then 1039 S.Waiting := False; 1040 S.State := False; 1041 1042 Result := pthread_cond_signal (S.CV'Access); 1043 pragma Assert (Result = 0); 1044 1045 else 1046 S.State := True; 1047 end if; 1048 1049 Result := pthread_mutex_unlock (S.L'Access); 1050 pragma Assert (Result = 0); 1051 1052 SSL.Abort_Undefer.all; 1053 end Set_True; 1054 1055 ------------------------ 1056 -- Suspend_Until_True -- 1057 ------------------------ 1058 1059 procedure Suspend_Until_True (S : in out Suspension_Object) is 1060 Result : Interfaces.C.int; 1061 1062 begin 1063 SSL.Abort_Defer.all; 1064 1065 Result := pthread_mutex_lock (S.L'Access); 1066 pragma Assert (Result = 0); 1067 1068 if S.Waiting then 1069 1070 -- Program_Error must be raised upon calling Suspend_Until_True 1071 -- if another task is already waiting on that suspension object 1072 -- (RM D.10(10)). 1073 1074 Result := pthread_mutex_unlock (S.L'Access); 1075 pragma Assert (Result = 0); 1076 1077 SSL.Abort_Undefer.all; 1078 1079 raise Program_Error; 1080 1081 else 1082 -- Suspend the task if the state is False. Otherwise, the task 1083 -- continues its execution, and the state of the suspension object 1084 -- is set to False (ARM D.10 par. 9). 1085 1086 if S.State then 1087 S.State := False; 1088 else 1089 S.Waiting := True; 1090 1091 loop 1092 -- Loop in case pthread_cond_wait returns earlier than expected 1093 -- (e.g. in case of EINTR caused by a signal). 1094 1095 Result := pthread_cond_wait (S.CV'Access, S.L'Access); 1096 pragma Assert (Result = 0 or else Result = EINTR); 1097 1098 exit when not S.Waiting; 1099 end loop; 1100 end if; 1101 1102 Result := pthread_mutex_unlock (S.L'Access); 1103 pragma Assert (Result = 0); 1104 1105 SSL.Abort_Undefer.all; 1106 end if; 1107 end Suspend_Until_True; 1108 1109 ---------------- 1110 -- Check_Exit -- 1111 ---------------- 1112 1113 -- Dummy version 1114 1115 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is 1116 pragma Unreferenced (Self_ID); 1117 begin 1118 return True; 1119 end Check_Exit; 1120 1121 -------------------- 1122 -- Check_No_Locks -- 1123 -------------------- 1124 1125 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is 1126 pragma Unreferenced (Self_ID); 1127 begin 1128 return True; 1129 end Check_No_Locks; 1130 1131 ---------------------- 1132 -- Environment_Task -- 1133 ---------------------- 1134 1135 function Environment_Task return Task_Id is 1136 begin 1137 return Environment_Task_Id; 1138 end Environment_Task; 1139 1140 -------------- 1141 -- Lock_RTS -- 1142 -------------- 1143 1144 procedure Lock_RTS is 1145 begin 1146 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1147 end Lock_RTS; 1148 1149 ---------------- 1150 -- Unlock_RTS -- 1151 ---------------- 1152 1153 procedure Unlock_RTS is 1154 begin 1155 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1156 end Unlock_RTS; 1157 1158 ------------------ 1159 -- Suspend_Task -- 1160 ------------------ 1161 1162 function Suspend_Task 1163 (T : ST.Task_Id; 1164 Thread_Self : Thread_Id) return Boolean 1165 is 1166 pragma Unreferenced (T); 1167 pragma Unreferenced (Thread_Self); 1168 begin 1169 return False; 1170 end Suspend_Task; 1171 1172 ----------------- 1173 -- Resume_Task -- 1174 ----------------- 1175 1176 function Resume_Task 1177 (T : ST.Task_Id; 1178 Thread_Self : Thread_Id) return Boolean 1179 is 1180 pragma Unreferenced (T); 1181 pragma Unreferenced (Thread_Self); 1182 begin 1183 return False; 1184 end Resume_Task; 1185 1186 -------------------- 1187 -- Stop_All_Tasks -- 1188 -------------------- 1189 1190 procedure Stop_All_Tasks is 1191 begin 1192 null; 1193 end Stop_All_Tasks; 1194 1195 --------------- 1196 -- Stop_Task -- 1197 --------------- 1198 1199 function Stop_Task (T : ST.Task_Id) return Boolean is 1200 pragma Unreferenced (T); 1201 begin 1202 return False; 1203 end Stop_Task; 1204 1205 ------------------- 1206 -- Continue_Task -- 1207 ------------------- 1208 1209 function Continue_Task (T : ST.Task_Id) return Boolean is 1210 pragma Unreferenced (T); 1211 begin 1212 return False; 1213 end Continue_Task; 1214 1215 ---------------- 1216 -- Initialize -- 1217 ---------------- 1218 1219 procedure Initialize (Environment_Task : Task_Id) is 1220 1221 -- The DEC Ada facility code defined in Starlet 1222 Ada_Facility : constant := 49; 1223 1224 function DBGEXT (Control_Block : System.Address) 1225 return System.Aux_DEC.Unsigned_Word; 1226 -- DBGEXT is imported from s-tasdeb.adb and its parameter re-typed 1227 -- as Address to avoid having a VMS specific s-tasdeb.ads. 1228 pragma Import (C, DBGEXT); 1229 pragma Import_Function (DBGEXT, "GNAT$DBGEXT"); 1230 1231 type Facility_Type is range 0 .. 65535; 1232 1233 procedure Debug_Register 1234 (ADBGEXT : System.Address; 1235 ATCB_Key : pthread_key_t; 1236 Facility : Facility_Type; 1237 Std_Prolog : Integer); 1238 pragma Import (C, Debug_Register, "CMA$DEBUG_REGISTER"); 1239 begin 1240 Environment_Task_Id := Environment_Task; 1241 1242 -- Initialize the lock used to synchronize chain of all ATCBs 1243 1244 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1245 1246 Specific.Initialize (Environment_Task); 1247 1248 -- Pass the context key on to CMA along with the other parameters 1249 Debug_Register 1250 ( 1251 DBGEXT'Address, -- Our DEBUG handling entry point 1252 ATCB_Key, -- CMA context key for our Ada TCB's 1253 Ada_Facility, -- Out facility code 1254 0 -- False, we don't have the std TCB prolog 1255 ); 1256 1257 -- Make environment task known here because it doesn't go through 1258 -- Activate_Tasks, which does it for all other tasks. 1259 1260 Known_Tasks (Known_Tasks'First) := Environment_Task; 1261 Environment_Task.Known_Tasks_Index := Known_Tasks'First; 1262 1263 Enter_Task (Environment_Task); 1264 end Initialize; 1265 1266 ----------------------- 1267 -- Set_Task_Affinity -- 1268 ----------------------- 1269 1270 procedure Set_Task_Affinity (T : ST.Task_Id) is 1271 pragma Unreferenced (T); 1272 1273 begin 1274 -- Setting task affinity is not supported by the underlying system 1275 1276 null; 1277 end Set_Task_Affinity; 1278end System.Task_Primitives.Operations; 1279