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 the VxWorks 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 System.Tasking.Debug; 44-- used for Known_Tasks 45 46with System.Interrupt_Management; 47-- used for Keep_Unmasked 48-- Abort_Task_Signal 49-- Signal_ID 50-- Initialize_Interrupts 51 52with System.Soft_Links; 53-- used for Defer/Undefer_Abort 54 55-- Note that we do not use System.Tasking.Initialization directly since 56-- this is a higher level package that we shouldn't depend on. For example 57-- when using the restricted run time, it is replaced by 58-- System.Tasking.Restricted.Initialization 59 60with System.OS_Interface; 61-- used for various type, constant, and operations 62 63with System.Parameters; 64-- used for Size_Type 65 66with System.Tasking; 67-- used for Ada_Task_Control_Block 68-- Task_ID 69-- ATCB components and types 70 71with Interfaces.C; 72 73with Unchecked_Conversion; 74with Unchecked_Deallocation; 75 76package body System.Task_Primitives.Operations is 77 78 use System.Tasking.Debug; 79 use System.Tasking; 80 use System.OS_Interface; 81 use System.Parameters; 82 use type Interfaces.C.int; 83 84 package SSL renames System.Soft_Links; 85 86 subtype int is System.OS_Interface.int; 87 88 Relative : constant := 0; 89 90 ---------------- 91 -- Local Data -- 92 ---------------- 93 94 -- The followings are logically constants, but need to be initialized 95 -- at run time. 96 97 Single_RTS_Lock : aliased RTS_Lock; 98 -- This is a lock to allow only one thread of control in the RTS at 99 -- a time; it is used to execute in mutual exclusion from all other tasks. 100 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List 101 102 ATCB_Key : aliased System.Address := System.Null_Address; 103 -- Key used to find the Ada Task_ID associated with a thread 104 105 ATCB_Key_Addr : System.Address := ATCB_Key'Address; 106 pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr"); 107 -- Exported to support the temporary AE653 task registration 108 -- implementation. This mechanism is used to minimize impact on other 109 -- targets. 110 111 Environment_Task_ID : Task_ID; 112 -- A variable to hold Task_ID for the environment task. 113 114 Unblocked_Signal_Mask : aliased sigset_t; 115 -- The set of signals that should unblocked in all tasks 116 117 -- The followings are internal configuration constants needed. 118 119 Time_Slice_Val : Integer; 120 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); 121 122 Locking_Policy : Character; 123 pragma Import (C, Locking_Policy, "__gl_locking_policy"); 124 125 Dispatching_Policy : Character; 126 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); 127 128 FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; 129 -- Indicates whether FIFO_Within_Priorities is set. 130 131 Mutex_Protocol : Priority_Type; 132 133 Foreign_Task_Elaborated : aliased Boolean := True; 134 -- Used to identified fake tasks (i.e., non-Ada Threads). 135 136 -------------------- 137 -- Local Packages -- 138 -------------------- 139 140 package Specific is 141 142 function Is_Valid_Task return Boolean; 143 pragma Inline (Is_Valid_Task); 144 -- Does executing thread have a TCB? 145 146 procedure Set (Self_Id : Task_ID); 147 pragma Inline (Set); 148 -- Set the self id for the current task. 149 150 function Self return Task_ID; 151 pragma Inline (Self); 152 -- Return a pointer to the Ada Task Control Block of the calling task. 153 154 end Specific; 155 156 package body Specific is separate; 157 -- The body of this package is target specific. 158 159 --------------------------------- 160 -- Support for foreign threads -- 161 --------------------------------- 162 163 function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; 164 -- Allocate and Initialize a new ATCB for the current Thread. 165 166 function Register_Foreign_Thread 167 (Thread : Thread_Id) return Task_ID is separate; 168 169 ----------------------- 170 -- Local Subprograms -- 171 ----------------------- 172 173 procedure Abort_Handler (signo : Signal); 174 -- Handler for the abort (SIGABRT) signal to handle asynchronous abortion. 175 176 procedure Install_Signal_Handlers; 177 -- Install the default signal handlers for the current task 178 179 function To_Address is new Unchecked_Conversion (Task_ID, System.Address); 180 181 ------------------- 182 -- Abort_Handler -- 183 ------------------- 184 185 procedure Abort_Handler (signo : Signal) is 186 pragma Unreferenced (signo); 187 188 Self_ID : constant Task_ID := Self; 189 Result : 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 Self_ID.Deferral_Level = 0 201 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 202 and then not Self_ID.Aborting 203 then 204 Self_ID.Aborting := True; 205 206 -- Make sure signals used for RTS internal purpose are unmasked 207 208 Result := pthread_sigmask (SIG_UNBLOCK, 209 Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); 210 pragma Assert (Result = 0); 211 212 raise Standard'Abort_Signal; 213 end if; 214 end Abort_Handler; 215 216 ----------------- 217 -- Stack_Guard -- 218 ----------------- 219 220 procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is 221 pragma Unreferenced (T); 222 pragma Unreferenced (On); 223 224 begin 225 -- Nothing needed (why not???) 226 227 null; 228 end Stack_Guard; 229 230 ------------------- 231 -- Get_Thread_Id -- 232 ------------------- 233 234 function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is 235 begin 236 return T.Common.LL.Thread; 237 end Get_Thread_Id; 238 239 ---------- 240 -- Self -- 241 ---------- 242 243 function Self return Task_ID renames Specific.Self; 244 245 ----------------------------- 246 -- Install_Signal_Handlers -- 247 ----------------------------- 248 249 procedure Install_Signal_Handlers is 250 act : aliased struct_sigaction; 251 old_act : aliased struct_sigaction; 252 Tmp_Set : aliased sigset_t; 253 Result : int; 254 255 begin 256 act.sa_flags := 0; 257 act.sa_handler := Abort_Handler'Address; 258 259 Result := sigemptyset (Tmp_Set'Access); 260 pragma Assert (Result = 0); 261 act.sa_mask := Tmp_Set; 262 263 Result := 264 sigaction 265 (Signal (Interrupt_Management.Abort_Task_Signal), 266 act'Unchecked_Access, 267 old_act'Unchecked_Access); 268 pragma Assert (Result = 0); 269 270 Interrupt_Management.Initialize_Interrupts; 271 end Install_Signal_Handlers; 272 273 --------------------- 274 -- Initialize_Lock -- 275 --------------------- 276 277 procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is 278 begin 279 L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); 280 L.Prio_Ceiling := int (Prio); 281 L.Protocol := Mutex_Protocol; 282 pragma Assert (L.Mutex /= 0); 283 end Initialize_Lock; 284 285 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is 286 pragma Unreferenced (Level); 287 288 begin 289 L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); 290 L.Prio_Ceiling := int (System.Any_Priority'Last); 291 L.Protocol := Mutex_Protocol; 292 pragma Assert (L.Mutex /= 0); 293 end Initialize_Lock; 294 295 ------------------- 296 -- Finalize_Lock -- 297 ------------------- 298 299 procedure Finalize_Lock (L : access Lock) is 300 Result : int; 301 302 begin 303 Result := semDelete (L.Mutex); 304 pragma Assert (Result = 0); 305 end Finalize_Lock; 306 307 procedure Finalize_Lock (L : access RTS_Lock) is 308 Result : int; 309 310 begin 311 Result := semDelete (L.Mutex); 312 pragma Assert (Result = 0); 313 end Finalize_Lock; 314 315 ---------------- 316 -- Write_Lock -- 317 ---------------- 318 319 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is 320 Result : int; 321 322 begin 323 if L.Protocol = Prio_Protect 324 and then int (Self.Common.Current_Priority) > L.Prio_Ceiling 325 then 326 Ceiling_Violation := True; 327 return; 328 else 329 Ceiling_Violation := False; 330 end if; 331 332 Result := semTake (L.Mutex, WAIT_FOREVER); 333 pragma Assert (Result = 0); 334 end Write_Lock; 335 336 procedure Write_Lock 337 (L : access RTS_Lock; 338 Global_Lock : Boolean := False) 339 is 340 Result : int; 341 342 begin 343 if not Single_Lock or else Global_Lock then 344 Result := semTake (L.Mutex, WAIT_FOREVER); 345 pragma Assert (Result = 0); 346 end if; 347 end Write_Lock; 348 349 procedure Write_Lock (T : Task_ID) is 350 Result : int; 351 352 begin 353 if not Single_Lock then 354 Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); 355 pragma Assert (Result = 0); 356 end if; 357 end Write_Lock; 358 359 --------------- 360 -- Read_Lock -- 361 --------------- 362 363 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is 364 begin 365 Write_Lock (L, Ceiling_Violation); 366 end Read_Lock; 367 368 ------------ 369 -- Unlock -- 370 ------------ 371 372 procedure Unlock (L : access Lock) is 373 Result : int; 374 375 begin 376 Result := semGive (L.Mutex); 377 pragma Assert (Result = 0); 378 end Unlock; 379 380 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is 381 Result : int; 382 383 begin 384 if not Single_Lock or else Global_Lock then 385 Result := semGive (L.Mutex); 386 pragma Assert (Result = 0); 387 end if; 388 end Unlock; 389 390 procedure Unlock (T : Task_ID) is 391 Result : int; 392 393 begin 394 if not Single_Lock then 395 Result := semGive (T.Common.LL.L.Mutex); 396 pragma Assert (Result = 0); 397 end if; 398 end Unlock; 399 400 ----------- 401 -- Sleep -- 402 ----------- 403 404 procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is 405 pragma Unreferenced (Reason); 406 407 Result : int; 408 409 begin 410 pragma Assert (Self_ID = Self); 411 412 -- Release the mutex before sleeping. 413 if Single_Lock then 414 Result := semGive (Single_RTS_Lock.Mutex); 415 else 416 Result := semGive (Self_ID.Common.LL.L.Mutex); 417 end if; 418 419 pragma Assert (Result = 0); 420 421 -- Perform a blocking operation to take the CV semaphore. 422 -- Note that a blocking operation in VxWorks will reenable 423 -- task scheduling. When we are no longer blocked and control 424 -- is returned, task scheduling will again be disabled. 425 426 Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); 427 pragma Assert (Result = 0); 428 429 -- Take the mutex back. 430 if Single_Lock then 431 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); 432 else 433 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); 434 end if; 435 436 pragma Assert (Result = 0); 437 end Sleep; 438 439 ----------------- 440 -- Timed_Sleep -- 441 ----------------- 442 443 -- This is for use within the run-time system, so abort is 444 -- assumed to be already deferred, and the caller should be 445 -- holding its own ATCB lock. 446 447 procedure Timed_Sleep 448 (Self_ID : Task_ID; 449 Time : Duration; 450 Mode : ST.Delay_Modes; 451 Reason : System.Tasking.Task_States; 452 Timedout : out Boolean; 453 Yielded : out Boolean) 454 is 455 pragma Unreferenced (Reason); 456 457 Orig : constant Duration := Monotonic_Clock; 458 Absolute : Duration; 459 Ticks : int; 460 Result : int; 461 Wakeup : Boolean := False; 462 463 begin 464 Timedout := False; 465 Yielded := True; 466 467 if Mode = Relative then 468 Absolute := Orig + Time; 469 470 -- Systematically add one since the first tick will delay 471 -- *at most* 1 / Rate_Duration seconds, so we need to add one to 472 -- be on the safe side. 473 474 Ticks := To_Clock_Ticks (Time); 475 476 if Ticks > 0 and then Ticks < int'Last then 477 Ticks := Ticks + 1; 478 end if; 479 480 else 481 Absolute := Time; 482 Ticks := To_Clock_Ticks (Time - Monotonic_Clock); 483 end if; 484 485 if Ticks > 0 then 486 loop 487 -- Release the mutex before sleeping. 488 if Single_Lock then 489 Result := semGive (Single_RTS_Lock.Mutex); 490 else 491 Result := semGive (Self_ID.Common.LL.L.Mutex); 492 end if; 493 494 pragma Assert (Result = 0); 495 496 -- Perform a blocking operation to take the CV semaphore. 497 -- Note that a blocking operation in VxWorks will reenable 498 -- task scheduling. When we are no longer blocked and control 499 -- is returned, task scheduling will again be disabled. 500 501 Result := semTake (Self_ID.Common.LL.CV, Ticks); 502 503 if Result = 0 then 504 -- Somebody may have called Wakeup for us 505 506 Wakeup := True; 507 508 else 509 if errno /= S_objLib_OBJ_TIMEOUT then 510 Wakeup := True; 511 else 512 -- If Ticks = int'last, it was most probably truncated 513 -- so let's make another round after recomputing Ticks 514 -- from the the absolute time. 515 516 if Ticks /= int'Last then 517 Timedout := True; 518 else 519 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); 520 521 if Ticks < 0 then 522 Timedout := True; 523 end if; 524 end if; 525 end if; 526 end if; 527 528 -- Take the mutex back. 529 if Single_Lock then 530 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); 531 else 532 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); 533 end if; 534 535 pragma Assert (Result = 0); 536 537 exit when Timedout or Wakeup; 538 end loop; 539 540 else 541 Timedout := True; 542 543 -- Should never hold a lock while yielding. 544 if Single_Lock then 545 Result := semGive (Single_RTS_Lock.Mutex); 546 taskDelay (0); 547 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); 548 549 else 550 Result := semGive (Self_ID.Common.LL.L.Mutex); 551 taskDelay (0); 552 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); 553 end if; 554 end if; 555 end Timed_Sleep; 556 557 ----------------- 558 -- Timed_Delay -- 559 ----------------- 560 561 -- This is for use in implementing delay statements, so 562 -- we assume the caller is holding no locks. 563 564 procedure Timed_Delay 565 (Self_ID : Task_ID; 566 Time : Duration; 567 Mode : ST.Delay_Modes) 568 is 569 Orig : constant Duration := Monotonic_Clock; 570 Absolute : Duration; 571 Ticks : int; 572 Timedout : Boolean; 573 Result : int; 574 Aborted : Boolean := False; 575 576 begin 577 SSL.Abort_Defer.all; 578 579 if Mode = Relative then 580 Absolute := Orig + Time; 581 Ticks := To_Clock_Ticks (Time); 582 583 if Ticks > 0 and then Ticks < int'Last then 584 585 -- The first tick will delay anytime between 0 and 586 -- 1 / sysClkRateGet seconds, so we need to add one to 587 -- be on the safe side. 588 589 Ticks := Ticks + 1; 590 end if; 591 592 else 593 Absolute := Time; 594 Ticks := To_Clock_Ticks (Time - Orig); 595 end if; 596 597 if Ticks > 0 then 598 -- Modifying State and Pending_Priority_Change, locking the TCB. 599 if Single_Lock then 600 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); 601 else 602 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); 603 end if; 604 605 pragma Assert (Result = 0); 606 607 Self_ID.Common.State := Delay_Sleep; 608 Timedout := False; 609 610 loop 611 if Self_ID.Pending_Priority_Change then 612 Self_ID.Pending_Priority_Change := False; 613 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; 614 Set_Priority (Self_ID, Self_ID.Common.Base_Priority); 615 end if; 616 617 Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 618 619 -- Release the TCB before sleeping 620 621 if Single_Lock then 622 Result := semGive (Single_RTS_Lock.Mutex); 623 else 624 Result := semGive (Self_ID.Common.LL.L.Mutex); 625 end if; 626 pragma Assert (Result = 0); 627 628 exit when Aborted; 629 630 Result := semTake (Self_ID.Common.LL.CV, Ticks); 631 632 if Result /= 0 then 633 -- If Ticks = int'last, it was most probably truncated 634 -- so let's make another round after recomputing Ticks 635 -- from the the absolute time. 636 637 if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then 638 Timedout := True; 639 else 640 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); 641 642 if Ticks < 0 then 643 Timedout := True; 644 end if; 645 end if; 646 end if; 647 648 -- Take back the lock after having slept, to protect further 649 -- access to Self_ID 650 651 if Single_Lock then 652 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); 653 else 654 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); 655 end if; 656 657 pragma Assert (Result = 0); 658 659 exit when Timedout; 660 end loop; 661 662 Self_ID.Common.State := Runnable; 663 664 if Single_Lock then 665 Result := semGive (Single_RTS_Lock.Mutex); 666 else 667 Result := semGive (Self_ID.Common.LL.L.Mutex); 668 end if; 669 670 else 671 taskDelay (0); 672 end if; 673 674 SSL.Abort_Undefer.all; 675 end Timed_Delay; 676 677 --------------------- 678 -- Monotonic_Clock -- 679 --------------------- 680 681 function Monotonic_Clock return Duration is 682 TS : aliased timespec; 683 Result : int; 684 685 begin 686 Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); 687 pragma Assert (Result = 0); 688 return To_Duration (TS); 689 end Monotonic_Clock; 690 691 ------------------- 692 -- RT_Resolution -- 693 ------------------- 694 695 function RT_Resolution return Duration is 696 begin 697 return 1.0 / Duration (sysClkRateGet); 698 end RT_Resolution; 699 700 ------------ 701 -- Wakeup -- 702 ------------ 703 704 procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is 705 pragma Unreferenced (Reason); 706 707 Result : int; 708 709 begin 710 Result := semGive (T.Common.LL.CV); 711 pragma Assert (Result = 0); 712 end Wakeup; 713 714 ----------- 715 -- Yield -- 716 ----------- 717 718 procedure Yield (Do_Yield : Boolean := True) is 719 pragma Unreferenced (Do_Yield); 720 Result : int; 721 pragma Unreferenced (Result); 722 begin 723 Result := taskDelay (0); 724 end Yield; 725 726 ------------------ 727 -- Set_Priority -- 728 ------------------ 729 730 type Prio_Array_Type is array (System.Any_Priority) of Integer; 731 pragma Atomic_Components (Prio_Array_Type); 732 733 Prio_Array : Prio_Array_Type; 734 -- Global array containing the id of the currently running task for 735 -- each priority. Note that we assume that we are on a single processor 736 -- with run-till-blocked scheduling. 737 738 procedure Set_Priority 739 (T : Task_ID; 740 Prio : System.Any_Priority; 741 Loss_Of_Inheritance : Boolean := False) 742 is 743 Array_Item : Integer; 744 Result : int; 745 746 begin 747 Result := 748 taskPrioritySet 749 (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); 750 pragma Assert (Result = 0); 751 752 if FIFO_Within_Priorities then 753 754 -- Annex D requirement [RM D.2.2 par. 9]: 755 -- If the task drops its priority due to the loss of inherited 756 -- priority, it is added at the head of the ready queue for its 757 -- new active priority. 758 759 if Loss_Of_Inheritance 760 and then Prio < T.Common.Current_Priority 761 then 762 Array_Item := Prio_Array (T.Common.Base_Priority) + 1; 763 Prio_Array (T.Common.Base_Priority) := Array_Item; 764 765 loop 766 -- Give some processes a chance to arrive 767 768 taskDelay (0); 769 770 -- Then wait for our turn to proceed 771 772 exit when Array_Item = Prio_Array (T.Common.Base_Priority) 773 or else Prio_Array (T.Common.Base_Priority) = 1; 774 end loop; 775 776 Prio_Array (T.Common.Base_Priority) := 777 Prio_Array (T.Common.Base_Priority) - 1; 778 end if; 779 end if; 780 781 T.Common.Current_Priority := Prio; 782 end Set_Priority; 783 784 ------------------ 785 -- Get_Priority -- 786 ------------------ 787 788 function Get_Priority (T : Task_ID) return System.Any_Priority is 789 begin 790 return T.Common.Current_Priority; 791 end Get_Priority; 792 793 ---------------- 794 -- Enter_Task -- 795 ---------------- 796 797 procedure Enter_Task (Self_ID : Task_ID) is 798 procedure Init_Float; 799 pragma Import (C, Init_Float, "__gnat_init_float"); 800 -- Properly initializes the FPU for PPC/MIPS systems. 801 802 begin 803 Self_ID.Common.LL.Thread := taskIdSelf; 804 Specific.Set (Self_ID); 805 806 Init_Float; 807 808 -- Install the signal handlers. 809 -- This is called for each task since there is no signal inheritance 810 -- between VxWorks tasks. 811 812 Install_Signal_Handlers; 813 814 Lock_RTS; 815 816 for J in Known_Tasks'Range loop 817 if Known_Tasks (J) = null then 818 Known_Tasks (J) := Self_ID; 819 Self_ID.Known_Tasks_Index := J; 820 exit; 821 end if; 822 end loop; 823 824 Unlock_RTS; 825 end Enter_Task; 826 827 -------------- 828 -- New_ATCB -- 829 -------------- 830 831 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is 832 begin 833 return new Ada_Task_Control_Block (Entry_Num); 834 end New_ATCB; 835 836 ------------------- 837 -- Is_Valid_Task -- 838 ------------------- 839 840 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 841 842 ----------------------------- 843 -- Register_Foreign_Thread -- 844 ----------------------------- 845 846 function Register_Foreign_Thread return Task_ID is 847 begin 848 if Is_Valid_Task then 849 return Self; 850 else 851 return Register_Foreign_Thread (taskIdSelf); 852 end if; 853 end Register_Foreign_Thread; 854 855 -------------------- 856 -- Initialize_TCB -- 857 -------------------- 858 859 procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is 860 begin 861 Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); 862 Self_ID.Common.LL.Thread := 0; 863 864 if Self_ID.Common.LL.CV = 0 then 865 Succeeded := False; 866 else 867 Succeeded := True; 868 869 if not Single_Lock then 870 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); 871 end if; 872 end if; 873 end Initialize_TCB; 874 875 ----------------- 876 -- Create_Task -- 877 ----------------- 878 879 procedure Create_Task 880 (T : Task_ID; 881 Wrapper : System.Address; 882 Stack_Size : System.Parameters.Size_Type; 883 Priority : System.Any_Priority; 884 Succeeded : out Boolean) 885 is 886 Adjusted_Stack_Size : size_t; 887 begin 888 if Stack_Size = Unspecified_Size then 889 Adjusted_Stack_Size := size_t (Default_Stack_Size); 890 891 elsif Stack_Size < Minimum_Stack_Size then 892 Adjusted_Stack_Size := size_t (Minimum_Stack_Size); 893 894 else 895 Adjusted_Stack_Size := size_t (Stack_Size); 896 end if; 897 898 -- Ask for 4 extra bytes of stack space so that the ATCB 899 -- pointer can be stored below the stack limit, plus extra 900 -- space for the frame of Task_Wrapper. This is so the user 901 -- gets the amount of stack requested exclusive of the needs 902 -- of the runtime. 903 -- 904 -- We also have to allocate n more bytes for the task name 905 -- storage and enough space for the Wind Task Control Block 906 -- which is around 0x778 bytes. VxWorks also seems to carve out 907 -- additional space, so use 2048 as a nice round number. 908 -- We might want to increment to the nearest page size in 909 -- case we ever support VxVMI. 910 -- 911 -- XXX - we should come back and visit this so we can 912 -- set the task name to something appropriate. 913 914 Adjusted_Stack_Size := Adjusted_Stack_Size + 2048; 915 916 -- Since the initial signal mask of a thread is inherited from the 917 -- creator, and the Environment task has all its signals masked, we 918 -- do not need to manipulate caller's signal mask at this point. 919 -- All tasks in RTS will have All_Tasks_Mask initially. 920 921 if T.Common.Task_Image_Len = 0 then 922 T.Common.LL.Thread := taskSpawn 923 (System.Null_Address, 924 To_VxWorks_Priority (int (Priority)), 925 VX_FP_TASK, 926 Adjusted_Stack_Size, 927 Wrapper, 928 To_Address (T)); 929 else 930 declare 931 Name : aliased String (1 .. T.Common.Task_Image_Len + 1); 932 begin 933 Name (1 .. Name'Last - 1) := 934 T.Common.Task_Image (1 .. T.Common.Task_Image_Len); 935 Name (Name'Last) := ASCII.NUL; 936 937 T.Common.LL.Thread := taskSpawn 938 (Name'Address, 939 To_VxWorks_Priority (int (Priority)), 940 VX_FP_TASK, 941 Adjusted_Stack_Size, 942 Wrapper, 943 To_Address (T)); 944 end; 945 end if; 946 947 if T.Common.LL.Thread = -1 then 948 Succeeded := False; 949 else 950 Succeeded := True; 951 end if; 952 953 Task_Creation_Hook (T.Common.LL.Thread); 954 Set_Priority (T, Priority); 955 end Create_Task; 956 957 ------------------ 958 -- Finalize_TCB -- 959 ------------------ 960 961 procedure Finalize_TCB (T : Task_ID) is 962 Result : int; 963 Tmp : Task_ID := T; 964 Is_Self : constant Boolean := (T = Self); 965 966 procedure Free is new 967 Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); 968 969 begin 970 if not Single_Lock then 971 Result := semDelete (T.Common.LL.L.Mutex); 972 pragma Assert (Result = 0); 973 end if; 974 975 T.Common.LL.Thread := 0; 976 977 Result := semDelete (T.Common.LL.CV); 978 pragma Assert (Result = 0); 979 980 if T.Known_Tasks_Index /= -1 then 981 Known_Tasks (T.Known_Tasks_Index) := null; 982 end if; 983 984 Free (Tmp); 985 986 if Is_Self then 987 Result := taskVarDelete (taskIdSelf, ATCB_Key'Access); 988 pragma Assert (Result /= ERROR); 989 end if; 990 end Finalize_TCB; 991 992 --------------- 993 -- Exit_Task -- 994 --------------- 995 996 procedure Exit_Task is 997 begin 998 Specific.Set (null); 999 end Exit_Task; 1000 1001 ---------------- 1002 -- Abort_Task -- 1003 ---------------- 1004 1005 procedure Abort_Task (T : Task_ID) is 1006 Result : int; 1007 1008 begin 1009 Result := kill (T.Common.LL.Thread, 1010 Signal (Interrupt_Management.Abort_Task_Signal)); 1011 pragma Assert (Result = 0); 1012 end Abort_Task; 1013 1014 ---------------- 1015 -- Check_Exit -- 1016 ---------------- 1017 1018 -- Dummy version 1019 1020 function Check_Exit (Self_ID : ST.Task_ID) return Boolean is 1021 pragma Unreferenced (Self_ID); 1022 1023 begin 1024 return True; 1025 end Check_Exit; 1026 1027 -------------------- 1028 -- Check_No_Locks -- 1029 -------------------- 1030 1031 function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is 1032 pragma Unreferenced (Self_ID); 1033 1034 begin 1035 return True; 1036 end Check_No_Locks; 1037 1038 ---------------------- 1039 -- Environment_Task -- 1040 ---------------------- 1041 1042 function Environment_Task return Task_ID is 1043 begin 1044 return Environment_Task_ID; 1045 end Environment_Task; 1046 1047 -------------- 1048 -- Lock_RTS -- 1049 -------------- 1050 1051 procedure Lock_RTS is 1052 begin 1053 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1054 end Lock_RTS; 1055 1056 ---------------- 1057 -- Unlock_RTS -- 1058 ---------------- 1059 1060 procedure Unlock_RTS is 1061 begin 1062 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1063 end Unlock_RTS; 1064 1065 ------------------ 1066 -- Suspend_Task -- 1067 ------------------ 1068 1069 function Suspend_Task 1070 (T : ST.Task_ID; 1071 Thread_Self : Thread_Id) 1072 return Boolean 1073 is 1074 begin 1075 if T.Common.LL.Thread /= 0 1076 and then T.Common.LL.Thread /= Thread_Self 1077 then 1078 return taskSuspend (T.Common.LL.Thread) = 0; 1079 else 1080 return True; 1081 end if; 1082 end Suspend_Task; 1083 1084 ----------------- 1085 -- Resume_Task -- 1086 ----------------- 1087 1088 function Resume_Task 1089 (T : ST.Task_ID; 1090 Thread_Self : Thread_Id) 1091 return Boolean 1092 is 1093 begin 1094 if T.Common.LL.Thread /= 0 1095 and then T.Common.LL.Thread /= Thread_Self 1096 then 1097 return taskResume (T.Common.LL.Thread) = 0; 1098 else 1099 return True; 1100 end if; 1101 end Resume_Task; 1102 1103 ---------------- 1104 -- Initialize -- 1105 ---------------- 1106 1107 procedure Initialize (Environment_Task : Task_ID) is 1108 Result : int; 1109 1110 begin 1111 if Locking_Policy = 'C' then 1112 Mutex_Protocol := Prio_Protect; 1113 elsif Locking_Policy = 'I' then 1114 Mutex_Protocol := Prio_Inherit; 1115 else 1116 Mutex_Protocol := Prio_None; 1117 end if; 1118 1119 if Time_Slice_Val > 0 then 1120 Result := kernelTimeSlice 1121 (To_Clock_Ticks 1122 (Duration (Time_Slice_Val) / Duration (1_000_000.0))); 1123 end if; 1124 1125 Result := sigemptyset (Unblocked_Signal_Mask'Access); 1126 pragma Assert (Result = 0); 1127 1128 for J in Interrupt_Management.Signal_ID loop 1129 if System.Interrupt_Management.Keep_Unmasked (J) then 1130 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); 1131 pragma Assert (Result = 0); 1132 end if; 1133 end loop; 1134 1135 Environment_Task_ID := Environment_Task; 1136 1137 -- Initialize the lock used to synchronize chain of all ATCBs. 1138 1139 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1140 1141 Enter_Task (Environment_Task); 1142 end Initialize; 1143 1144end System.Task_Primitives.Operations; 1145