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-2019, 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 the VxWorks 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.Multiprocessors; 46with System.Tasking.Debug; 47with System.Interrupt_Management; 48with System.Float_Control; 49with System.OS_Constants; 50 51with System.Soft_Links; 52-- We use System.Soft_Links instead of System.Tasking.Initialization 53-- because the later is a higher level package that we shouldn't depend 54-- on. For example when using the restricted run time, it is replaced by 55-- System.Tasking.Restricted.Stages. 56 57with System.Task_Info; 58with System.VxWorks.Ext; 59 60package body System.Task_Primitives.Operations is 61 62 package OSC renames System.OS_Constants; 63 package SSL renames System.Soft_Links; 64 65 use System.Tasking.Debug; 66 use System.Tasking; 67 use System.OS_Interface; 68 use System.Parameters; 69 use type System.VxWorks.Ext.t_id; 70 use type Interfaces.C.int; 71 use type System.OS_Interface.unsigned; 72 73 subtype int is System.OS_Interface.int; 74 subtype unsigned is System.OS_Interface.unsigned; 75 76 Relative : constant := 0; 77 78 ---------------- 79 -- Local Data -- 80 ---------------- 81 82 -- The followings are logically constants, but need to be initialized at 83 -- run time. 84 85 Environment_Task_Id : Task_Id; 86 -- A variable to hold Task_Id for the environment task 87 88 -- The followings are internal configuration constants needed 89 90 Dispatching_Policy : Character; 91 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); 92 93 Foreign_Task_Elaborated : aliased Boolean := True; 94 -- Used to identified fake tasks (i.e., non-Ada Threads) 95 96 Locking_Policy : Character; 97 pragma Import (C, Locking_Policy, "__gl_locking_policy"); 98 99 Mutex_Protocol : Priority_Type; 100 101 Single_RTS_Lock : aliased RTS_Lock; 102 -- This is a lock to allow only one thread of control in the RTS at a 103 -- time; it is used to execute in mutual exclusion from all other tasks. 104 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List 105 106 Time_Slice_Val : Integer; 107 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); 108 109 Null_Thread_Id : constant Thread_Id := 0; 110 -- Constant to indicate that the thread identifier has not yet been 111 -- initialized. 112 113 -------------------- 114 -- Local Packages -- 115 -------------------- 116 117 package Specific is 118 119 procedure Initialize; 120 pragma Inline (Initialize); 121 -- Initialize task specific data 122 123 function Is_Valid_Task return Boolean; 124 pragma Inline (Is_Valid_Task); 125 -- Does executing thread have a TCB? 126 127 procedure Set (Self_Id : Task_Id); 128 pragma Inline (Set); 129 -- Set the self id for the current task, unless Self_Id is null, in 130 -- which case the task specific data is deleted. 131 132 function Self return Task_Id; 133 pragma Inline (Self); 134 -- Return a pointer to the Ada Task Control Block of the calling task 135 136 end Specific; 137 138 package body Specific is separate; 139 -- The body of this package is target specific 140 141 ---------------------------------- 142 -- ATCB allocation/deallocation -- 143 ---------------------------------- 144 145 package body ATCB_Allocation is separate; 146 -- The body of this package is shared across several targets 147 148 --------------------------------- 149 -- Support for foreign threads -- 150 --------------------------------- 151 152 function Register_Foreign_Thread 153 (Thread : Thread_Id; 154 Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; 155 -- Allocate and initialize a new ATCB for the current Thread. The size of 156 -- the secondary stack can be optionally specified. 157 158 function Register_Foreign_Thread 159 (Thread : Thread_Id; 160 Sec_Stack_Size : Size_Type := Unspecified_Size) 161 return Task_Id is separate; 162 163 ----------------------- 164 -- Local Subprograms -- 165 ----------------------- 166 167 procedure Abort_Handler (signo : Signal); 168 -- Handler for the abort (SIGABRT) signal to handle asynchronous abort 169 170 procedure Install_Signal_Handlers; 171 -- Install the default signal handlers for the current task 172 173 function Is_Task_Context return Boolean; 174 -- This function returns True if the current execution is in the context of 175 -- a task, and False if it is an interrupt context. 176 177 type Set_Stack_Limit_Proc_Acc is access procedure; 178 pragma Convention (C, Set_Stack_Limit_Proc_Acc); 179 180 Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; 181 pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); 182 -- Procedure to be called when a task is created to set stack limit. Used 183 -- only for VxWorks 5 and VxWorks MILS guest OS. 184 185 function To_Address is 186 new Ada.Unchecked_Conversion (Task_Id, System.Address); 187 188 ------------------- 189 -- Abort_Handler -- 190 ------------------- 191 192 procedure Abort_Handler (signo : Signal) is 193 pragma Unreferenced (signo); 194 195 -- Do not call Self at this point as we're in a signal handler 196 -- and it may not be available, in particular on targets where we 197 -- support ZCX and where we don't do anything here anyway. 198 Self_ID : Task_Id; 199 Old_Set : aliased sigset_t; 200 Unblocked_Mask : aliased sigset_t; 201 Result : int; 202 pragma Warnings (Off, Result); 203 204 use System.Interrupt_Management; 205 206 begin 207 -- It is not safe to raise an exception when using ZCX and the GCC 208 -- exception handling mechanism. 209 210 if ZCX_By_Default then 211 return; 212 end if; 213 214 Self_ID := Self; 215 216 if Self_ID.Deferral_Level = 0 217 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 218 and then not Self_ID.Aborting 219 then 220 Self_ID.Aborting := True; 221 222 -- Make sure signals used for RTS internal purposes are unmasked 223 224 Result := sigemptyset (Unblocked_Mask'Access); 225 pragma Assert (Result = 0); 226 Result := 227 sigaddset 228 (Unblocked_Mask'Access, 229 Signal (Abort_Task_Interrupt)); 230 pragma Assert (Result = 0); 231 Result := sigaddset (Unblocked_Mask'Access, SIGBUS); 232 pragma Assert (Result = 0); 233 Result := sigaddset (Unblocked_Mask'Access, SIGFPE); 234 pragma Assert (Result = 0); 235 Result := sigaddset (Unblocked_Mask'Access, SIGILL); 236 pragma Assert (Result = 0); 237 Result := sigaddset (Unblocked_Mask'Access, SIGSEGV); 238 pragma Assert (Result = 0); 239 240 Result := 241 pthread_sigmask 242 (SIG_UNBLOCK, 243 Unblocked_Mask'Access, 244 Old_Set'Access); 245 pragma Assert (Result = 0); 246 247 raise Standard'Abort_Signal; 248 end if; 249 end Abort_Handler; 250 251 ----------------- 252 -- Stack_Guard -- 253 ----------------- 254 255 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is 256 pragma Unreferenced (T); 257 pragma Unreferenced (On); 258 259 begin 260 -- Nothing needed (why not???) 261 262 null; 263 end Stack_Guard; 264 265 ------------------- 266 -- Get_Thread_Id -- 267 ------------------- 268 269 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is 270 begin 271 return T.Common.LL.Thread; 272 end Get_Thread_Id; 273 274 ---------- 275 -- Self -- 276 ---------- 277 278 function Self return Task_Id renames Specific.Self; 279 280 ----------------------------- 281 -- Install_Signal_Handlers -- 282 ----------------------------- 283 284 procedure Install_Signal_Handlers is 285 act : aliased struct_sigaction; 286 old_act : aliased struct_sigaction; 287 Tmp_Set : aliased sigset_t; 288 Result : int; 289 290 begin 291 act.sa_flags := 0; 292 act.sa_handler := Abort_Handler'Address; 293 294 Result := sigemptyset (Tmp_Set'Access); 295 pragma Assert (Result = 0); 296 act.sa_mask := Tmp_Set; 297 298 Result := 299 sigaction 300 (Signal (Interrupt_Management.Abort_Task_Interrupt), 301 act'Unchecked_Access, 302 old_act'Unchecked_Access); 303 pragma Assert (Result = 0); 304 305 Interrupt_Management.Initialize_Interrupts; 306 end Install_Signal_Handlers; 307 308 --------------------- 309 -- Initialize_Lock -- 310 --------------------- 311 312 procedure Initialize_Lock 313 (Prio : System.Any_Priority; 314 L : not null access Lock) 315 is 316 begin 317 L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); 318 L.Prio_Ceiling := int (Prio); 319 L.Protocol := Mutex_Protocol; 320 pragma Assert (L.Mutex /= 0); 321 end Initialize_Lock; 322 323 procedure Initialize_Lock 324 (L : not null access RTS_Lock; 325 Level : Lock_Level) 326 is 327 pragma Unreferenced (Level); 328 begin 329 L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); 330 L.Prio_Ceiling := int (System.Any_Priority'Last); 331 L.Protocol := Mutex_Protocol; 332 pragma Assert (L.Mutex /= 0); 333 end Initialize_Lock; 334 335 ------------------- 336 -- Finalize_Lock -- 337 ------------------- 338 339 procedure Finalize_Lock (L : not null access Lock) is 340 Result : int; 341 begin 342 Result := semDelete (L.Mutex); 343 pragma Assert (Result = 0); 344 end Finalize_Lock; 345 346 procedure Finalize_Lock (L : not null access RTS_Lock) is 347 Result : int; 348 begin 349 Result := semDelete (L.Mutex); 350 pragma Assert (Result = 0); 351 end Finalize_Lock; 352 353 ---------------- 354 -- Write_Lock -- 355 ---------------- 356 357 procedure Write_Lock 358 (L : not null access Lock; 359 Ceiling_Violation : out Boolean) 360 is 361 Result : int; 362 363 begin 364 if L.Protocol = Prio_Protect 365 and then int (Self.Common.Current_Priority) > L.Prio_Ceiling 366 then 367 Ceiling_Violation := True; 368 return; 369 else 370 Ceiling_Violation := False; 371 end if; 372 373 Result := semTake (L.Mutex, WAIT_FOREVER); 374 pragma Assert (Result = 0); 375 end Write_Lock; 376 377 procedure Write_Lock 378 (L : not null access RTS_Lock; 379 Global_Lock : Boolean := False) 380 is 381 Result : int; 382 begin 383 if not Single_Lock or else Global_Lock then 384 Result := semTake (L.Mutex, WAIT_FOREVER); 385 pragma Assert (Result = 0); 386 end if; 387 end Write_Lock; 388 389 procedure Write_Lock (T : Task_Id) is 390 Result : int; 391 begin 392 if not Single_Lock then 393 Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); 394 pragma Assert (Result = 0); 395 end if; 396 end Write_Lock; 397 398 --------------- 399 -- Read_Lock -- 400 --------------- 401 402 procedure Read_Lock 403 (L : not null access Lock; 404 Ceiling_Violation : out Boolean) 405 is 406 begin 407 Write_Lock (L, Ceiling_Violation); 408 end Read_Lock; 409 410 ------------ 411 -- Unlock -- 412 ------------ 413 414 procedure Unlock (L : not null access Lock) is 415 Result : int; 416 begin 417 Result := semGive (L.Mutex); 418 pragma Assert (Result = 0); 419 end Unlock; 420 421 procedure Unlock 422 (L : not null access RTS_Lock; 423 Global_Lock : Boolean := False) 424 is 425 Result : int; 426 begin 427 if not Single_Lock or else Global_Lock then 428 Result := semGive (L.Mutex); 429 pragma Assert (Result = 0); 430 end if; 431 end Unlock; 432 433 procedure Unlock (T : Task_Id) is 434 Result : int; 435 begin 436 if not Single_Lock then 437 Result := semGive (T.Common.LL.L.Mutex); 438 pragma Assert (Result = 0); 439 end if; 440 end Unlock; 441 442 ----------------- 443 -- Set_Ceiling -- 444 ----------------- 445 446 -- Dynamic priority ceilings are not supported by the underlying system 447 448 procedure Set_Ceiling 449 (L : not null access Lock; 450 Prio : System.Any_Priority) 451 is 452 pragma Unreferenced (L, Prio); 453 begin 454 null; 455 end Set_Ceiling; 456 457 ----------- 458 -- Sleep -- 459 ----------- 460 461 procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is 462 pragma Unreferenced (Reason); 463 464 Result : int; 465 466 begin 467 pragma Assert (Self_ID = Self); 468 469 -- Release the mutex before sleeping 470 471 Result := 472 semGive (if Single_Lock 473 then Single_RTS_Lock.Mutex 474 else Self_ID.Common.LL.L.Mutex); 475 pragma Assert (Result = 0); 476 477 -- Perform a blocking operation to take the CV semaphore. Note that a 478 -- blocking operation in VxWorks will reenable task scheduling. When we 479 -- are no longer blocked and control is returned, task scheduling will 480 -- again be disabled. 481 482 Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); 483 pragma Assert (Result = 0); 484 485 -- Take the mutex back 486 487 Result := 488 semTake ((if Single_Lock 489 then Single_RTS_Lock.Mutex 490 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); 491 pragma Assert (Result = 0); 492 end Sleep; 493 494 ----------------- 495 -- Timed_Sleep -- 496 ----------------- 497 498 -- This is for use within the run-time system, so abort is assumed to be 499 -- already deferred, and the caller should be holding its own ATCB lock. 500 501 procedure Timed_Sleep 502 (Self_ID : Task_Id; 503 Time : Duration; 504 Mode : ST.Delay_Modes; 505 Reason : System.Tasking.Task_States; 506 Timedout : out Boolean; 507 Yielded : out Boolean) 508 is 509 pragma Unreferenced (Reason); 510 511 Orig : constant Duration := Monotonic_Clock; 512 Absolute : Duration; 513 Ticks : int; 514 Result : int; 515 Wakeup : Boolean := False; 516 517 begin 518 Timedout := False; 519 Yielded := True; 520 521 if Mode = Relative then 522 Absolute := Orig + Time; 523 524 -- Systematically add one since the first tick will delay *at most* 525 -- 1 / Rate_Duration seconds, so we need to add one to be on the 526 -- safe side. 527 528 Ticks := To_Clock_Ticks (Time); 529 530 if Ticks > 0 and then Ticks < int'Last then 531 Ticks := Ticks + 1; 532 end if; 533 534 else 535 Absolute := Time; 536 Ticks := To_Clock_Ticks (Time - Monotonic_Clock); 537 end if; 538 539 if Ticks > 0 then 540 loop 541 -- Release the mutex before sleeping 542 543 Result := 544 semGive (if Single_Lock 545 then Single_RTS_Lock.Mutex 546 else Self_ID.Common.LL.L.Mutex); 547 pragma Assert (Result = 0); 548 549 -- Perform a blocking operation to take the CV semaphore. Note 550 -- that a blocking operation in VxWorks will reenable task 551 -- scheduling. When we are no longer blocked and control is 552 -- returned, task scheduling will again be disabled. 553 554 Result := semTake (Self_ID.Common.LL.CV, Ticks); 555 556 if Result = 0 then 557 558 -- Somebody may have called Wakeup for us 559 560 Wakeup := True; 561 562 else 563 if errno /= S_objLib_OBJ_TIMEOUT then 564 Wakeup := True; 565 566 else 567 -- If Ticks = int'last, it was most probably truncated so 568 -- let's make another round after recomputing Ticks from 569 -- the absolute time. 570 571 if Ticks /= int'Last then 572 Timedout := True; 573 574 else 575 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); 576 577 if Ticks < 0 then 578 Timedout := True; 579 end if; 580 end if; 581 end if; 582 end if; 583 584 -- Take the mutex back 585 586 Result := 587 semTake ((if Single_Lock 588 then Single_RTS_Lock.Mutex 589 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); 590 pragma Assert (Result = 0); 591 592 exit when Timedout or Wakeup; 593 end loop; 594 595 else 596 Timedout := True; 597 598 -- Should never hold a lock while yielding 599 600 if Single_Lock then 601 Result := semGive (Single_RTS_Lock.Mutex); 602 Result := taskDelay (0); 603 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); 604 605 else 606 Result := semGive (Self_ID.Common.LL.L.Mutex); 607 Result := taskDelay (0); 608 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); 609 end if; 610 end if; 611 end Timed_Sleep; 612 613 ----------------- 614 -- Timed_Delay -- 615 ----------------- 616 617 -- This is for use in implementing delay statements, so we assume the 618 -- caller is holding no locks. 619 620 procedure Timed_Delay 621 (Self_ID : Task_Id; 622 Time : Duration; 623 Mode : ST.Delay_Modes) 624 is 625 Orig : constant Duration := Monotonic_Clock; 626 Absolute : Duration; 627 Ticks : int; 628 Timedout : Boolean; 629 Aborted : Boolean := False; 630 631 Result : int; 632 pragma Warnings (Off, Result); 633 634 begin 635 if Mode = Relative then 636 Absolute := Orig + Time; 637 Ticks := To_Clock_Ticks (Time); 638 639 if Ticks > 0 and then Ticks < int'Last then 640 641 -- First tick will delay anytime between 0 and 1 / sysClkRateGet 642 -- seconds, so we need to add one to be on the safe side. 643 644 Ticks := Ticks + 1; 645 end if; 646 647 else 648 Absolute := Time; 649 Ticks := To_Clock_Ticks (Time - Orig); 650 end if; 651 652 if Ticks > 0 then 653 654 -- Modifying State, locking the TCB 655 656 Result := 657 semTake ((if Single_Lock 658 then Single_RTS_Lock.Mutex 659 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); 660 661 pragma Assert (Result = 0); 662 663 Self_ID.Common.State := Delay_Sleep; 664 Timedout := False; 665 666 loop 667 Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 668 669 -- Release the TCB before sleeping 670 671 Result := 672 semGive (if Single_Lock 673 then Single_RTS_Lock.Mutex 674 else Self_ID.Common.LL.L.Mutex); 675 pragma Assert (Result = 0); 676 677 exit when Aborted; 678 679 Result := semTake (Self_ID.Common.LL.CV, Ticks); 680 681 if Result /= 0 then 682 683 -- If Ticks = int'last, it was most probably truncated, so make 684 -- another round after recomputing Ticks from absolute time. 685 686 if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then 687 Timedout := True; 688 else 689 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); 690 691 if Ticks < 0 then 692 Timedout := True; 693 end if; 694 end if; 695 end if; 696 697 -- Take back the lock after having slept, to protect further 698 -- access to Self_ID. 699 700 Result := 701 semTake 702 ((if Single_Lock 703 then Single_RTS_Lock.Mutex 704 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); 705 706 pragma Assert (Result = 0); 707 708 exit when Timedout; 709 end loop; 710 711 Self_ID.Common.State := Runnable; 712 713 Result := 714 semGive 715 (if Single_Lock 716 then Single_RTS_Lock.Mutex 717 else Self_ID.Common.LL.L.Mutex); 718 719 else 720 Result := taskDelay (0); 721 end if; 722 end Timed_Delay; 723 724 --------------------- 725 -- Monotonic_Clock -- 726 --------------------- 727 728 function Monotonic_Clock return Duration is 729 TS : aliased timespec; 730 Result : int; 731 begin 732 Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); 733 pragma Assert (Result = 0); 734 return To_Duration (TS); 735 end Monotonic_Clock; 736 737 ------------------- 738 -- RT_Resolution -- 739 ------------------- 740 741 function RT_Resolution return Duration is 742 begin 743 return 1.0 / Duration (sysClkRateGet); 744 end RT_Resolution; 745 746 ------------ 747 -- Wakeup -- 748 ------------ 749 750 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is 751 pragma Unreferenced (Reason); 752 Result : int; 753 begin 754 Result := semGive (T.Common.LL.CV); 755 pragma Assert (Result = 0); 756 end Wakeup; 757 758 ----------- 759 -- Yield -- 760 ----------- 761 762 procedure Yield (Do_Yield : Boolean := True) is 763 pragma Unreferenced (Do_Yield); 764 Result : int; 765 pragma Unreferenced (Result); 766 begin 767 Result := taskDelay (0); 768 end Yield; 769 770 ------------------ 771 -- Set_Priority -- 772 ------------------ 773 774 procedure Set_Priority 775 (T : Task_Id; 776 Prio : System.Any_Priority; 777 Loss_Of_Inheritance : Boolean := False) 778 is 779 pragma Unreferenced (Loss_Of_Inheritance); 780 781 Result : int; 782 783 begin 784 Result := 785 taskPrioritySet 786 (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); 787 pragma Assert (Result = 0); 788 789 -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of 790 -- the priority queue instead of the head. This is not the behavior 791 -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable 792 -- variation (RM 1.1.3(6)), given this is the built-in behavior of the 793 -- operating system. VxWorks versions starting from 6.7 implement the 794 -- required Annex D semantics. 795 796 -- In older versions we attempted to better approximate the Annex D 797 -- required behavior, but this simulation was not entirely accurate, 798 -- and it seems better to live with the standard VxWorks semantics. 799 800 T.Common.Current_Priority := Prio; 801 end Set_Priority; 802 803 ------------------ 804 -- Get_Priority -- 805 ------------------ 806 807 function Get_Priority (T : Task_Id) return System.Any_Priority is 808 begin 809 return T.Common.Current_Priority; 810 end Get_Priority; 811 812 ---------------- 813 -- Enter_Task -- 814 ---------------- 815 816 procedure Enter_Task (Self_ID : Task_Id) is 817 begin 818 -- Store the user-level task id in the Thread field (to be used 819 -- internally by the run-time system) and the kernel-level task id in 820 -- the LWP field (to be used by the debugger). 821 822 Self_ID.Common.LL.Thread := taskIdSelf; 823 Self_ID.Common.LL.LWP := getpid; 824 825 Specific.Set (Self_ID); 826 827 -- Properly initializes the FPU for PPC/MIPS systems 828 829 System.Float_Control.Reset; 830 831 -- Install the signal handlers 832 833 -- This is called for each task since there is no signal inheritance 834 -- between VxWorks tasks. 835 836 Install_Signal_Handlers; 837 838 -- If stack checking is enabled, set the stack limit for this task 839 840 if Set_Stack_Limit_Hook /= null then 841 Set_Stack_Limit_Hook.all; 842 end if; 843 end Enter_Task; 844 845 ------------------- 846 -- Is_Valid_Task -- 847 ------------------- 848 849 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 850 851 ----------------------------- 852 -- Register_Foreign_Thread -- 853 ----------------------------- 854 855 function Register_Foreign_Thread return Task_Id is 856 begin 857 if Is_Valid_Task then 858 return Self; 859 else 860 return Register_Foreign_Thread (taskIdSelf); 861 end if; 862 end Register_Foreign_Thread; 863 864 -------------------- 865 -- Initialize_TCB -- 866 -------------------- 867 868 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is 869 begin 870 Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); 871 Self_ID.Common.LL.Thread := Null_Thread_Id; 872 873 if Self_ID.Common.LL.CV = 0 then 874 Succeeded := False; 875 876 else 877 Succeeded := True; 878 879 if not Single_Lock then 880 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); 881 end if; 882 end if; 883 end Initialize_TCB; 884 885 ----------------- 886 -- Create_Task -- 887 ----------------- 888 889 procedure Create_Task 890 (T : Task_Id; 891 Wrapper : System.Address; 892 Stack_Size : System.Parameters.Size_Type; 893 Priority : System.Any_Priority; 894 Succeeded : out Boolean) 895 is 896 Adjusted_Stack_Size : size_t; 897 898 use type System.Multiprocessors.CPU_Range; 899 900 begin 901 -- Check whether both Dispatching_Domain and CPU are specified for 902 -- the task, and the CPU value is not contained within the range of 903 -- processors for the domain. 904 905 if T.Common.Domain /= null 906 and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU 907 and then 908 (T.Common.Base_CPU not in T.Common.Domain'Range 909 or else not T.Common.Domain (T.Common.Base_CPU)) 910 then 911 Succeeded := False; 912 return; 913 end if; 914 915 -- Ask for four extra bytes of stack space so that the ATCB pointer can 916 -- be stored below the stack limit, plus extra space for the frame of 917 -- Task_Wrapper. This is so the user gets the amount of stack requested 918 -- exclusive of the needs. 919 920 -- We also have to allocate n more bytes for the task name storage and 921 -- enough space for the Wind Task Control Block which is around 0x778 922 -- bytes. VxWorks also seems to carve out additional space, so use 2048 923 -- as a nice round number. We might want to increment to the nearest 924 -- page size in case we ever support VxVMI. 925 926 -- ??? - we should come back and visit this so we can set the task name 927 -- to something appropriate. 928 929 Adjusted_Stack_Size := size_t (Stack_Size) + 2048; 930 931 -- Since the initial signal mask of a thread is inherited from the 932 -- creator, and the Environment task has all its signals masked, we do 933 -- not need to manipulate caller's signal mask at this point. All tasks 934 -- in RTS will have All_Tasks_Mask initially. 935 936 -- We now compute the VxWorks task name and options, then spawn ... 937 938 declare 939 Name : aliased String (1 .. T.Common.Task_Image_Len + 1); 940 Name_Address : System.Address; 941 -- Task name we are going to hand down to VxWorks 942 943 function Get_Task_Options return int; 944 pragma Import (C, Get_Task_Options, "__gnat_get_task_options"); 945 -- Function that returns the options to be set for the task that we 946 -- are creating. We fetch the options assigned to the current task, 947 -- so offering some user level control over the options for a task 948 -- hierarchy, and force VX_FP_TASK because it is almost always 949 -- required. 950 951 begin 952 -- If there is no Ada task name handy, let VxWorks choose one. 953 -- Otherwise, tell VxWorks what the Ada task name is. 954 955 if T.Common.Task_Image_Len = 0 then 956 Name_Address := System.Null_Address; 957 else 958 Name (1 .. Name'Last - 1) := 959 T.Common.Task_Image (1 .. T.Common.Task_Image_Len); 960 Name (Name'Last) := ASCII.NUL; 961 Name_Address := Name'Address; 962 end if; 963 964 -- Now spawn the VxWorks task for real 965 966 T.Common.LL.Thread := 967 taskSpawn 968 (Name_Address, 969 To_VxWorks_Priority (int (Priority)), 970 Get_Task_Options, 971 Adjusted_Stack_Size, 972 Wrapper, 973 To_Address (T)); 974 end; 975 976 -- Set processor affinity 977 978 Set_Task_Affinity (T); 979 980 -- Only case of failure is if taskSpawn returned 0 (aka Null_Thread_Id) 981 982 if T.Common.LL.Thread = Null_Thread_Id then 983 Succeeded := False; 984 else 985 Succeeded := True; 986 Task_Creation_Hook (T.Common.LL.Thread); 987 Set_Priority (T, Priority); 988 end if; 989 end Create_Task; 990 991 ------------------ 992 -- Finalize_TCB -- 993 ------------------ 994 995 procedure Finalize_TCB (T : Task_Id) is 996 Result : int; 997 998 begin 999 if not Single_Lock then 1000 Result := semDelete (T.Common.LL.L.Mutex); 1001 pragma Assert (Result = 0); 1002 end if; 1003 1004 T.Common.LL.Thread := Null_Thread_Id; 1005 1006 Result := semDelete (T.Common.LL.CV); 1007 pragma Assert (Result = 0); 1008 1009 if T.Known_Tasks_Index /= -1 then 1010 Known_Tasks (T.Known_Tasks_Index) := null; 1011 end if; 1012 1013 ATCB_Allocation.Free_ATCB (T); 1014 end Finalize_TCB; 1015 1016 --------------- 1017 -- Exit_Task -- 1018 --------------- 1019 1020 procedure Exit_Task is 1021 begin 1022 Specific.Set (null); 1023 end Exit_Task; 1024 1025 ---------------- 1026 -- Abort_Task -- 1027 ---------------- 1028 1029 procedure Abort_Task (T : Task_Id) is 1030 Result : int; 1031 begin 1032 Result := 1033 kill 1034 (T.Common.LL.Thread, 1035 Signal (Interrupt_Management.Abort_Task_Interrupt)); 1036 pragma Assert (Result = 0); 1037 end Abort_Task; 1038 1039 ---------------- 1040 -- Initialize -- 1041 ---------------- 1042 1043 procedure Initialize (S : in out Suspension_Object) is 1044 begin 1045 -- Initialize internal state (always to False (RM D.10(6))) 1046 1047 S.State := False; 1048 S.Waiting := False; 1049 1050 -- Initialize internal mutex 1051 1052 -- Use simpler binary semaphore instead of VxWorks mutual exclusion 1053 -- semaphore, because we don't need the fancier semantics and their 1054 -- overhead. 1055 1056 S.L := semBCreate (SEM_Q_FIFO, SEM_FULL); 1057 1058 -- Initialize internal condition variable 1059 1060 S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY); 1061 end Initialize; 1062 1063 -------------- 1064 -- Finalize -- 1065 -------------- 1066 1067 procedure Finalize (S : in out Suspension_Object) is 1068 pragma Unmodified (S); 1069 -- S may be modified on other targets, but not on VxWorks 1070 1071 Result : STATUS; 1072 1073 begin 1074 -- Destroy internal mutex 1075 1076 Result := semDelete (S.L); 1077 pragma Assert (Result = OK); 1078 1079 -- Destroy internal condition variable 1080 1081 Result := semDelete (S.CV); 1082 pragma Assert (Result = OK); 1083 end Finalize; 1084 1085 ------------------- 1086 -- Current_State -- 1087 ------------------- 1088 1089 function Current_State (S : Suspension_Object) return Boolean is 1090 begin 1091 -- We do not want to use lock on this read operation. State is marked 1092 -- as Atomic so that we ensure that the value retrieved is correct. 1093 1094 return S.State; 1095 end Current_State; 1096 1097 --------------- 1098 -- Set_False -- 1099 --------------- 1100 1101 procedure Set_False (S : in out Suspension_Object) is 1102 Result : STATUS; 1103 1104 begin 1105 SSL.Abort_Defer.all; 1106 1107 Result := semTake (S.L, WAIT_FOREVER); 1108 pragma Assert (Result = OK); 1109 1110 S.State := False; 1111 1112 Result := semGive (S.L); 1113 pragma Assert (Result = OK); 1114 1115 SSL.Abort_Undefer.all; 1116 end Set_False; 1117 1118 -------------- 1119 -- Set_True -- 1120 -------------- 1121 1122 procedure Set_True (S : in out Suspension_Object) is 1123 Result : STATUS; 1124 1125 begin 1126 -- Set_True can be called from an interrupt context, in which case 1127 -- Abort_Defer is undefined. 1128 1129 if Is_Task_Context then 1130 SSL.Abort_Defer.all; 1131 end if; 1132 1133 Result := semTake (S.L, WAIT_FOREVER); 1134 pragma Assert (Result = OK); 1135 1136 -- If there is already a task waiting on this suspension object then we 1137 -- resume it, leaving the state of the suspension object to False, as it 1138 -- is specified in (RM D.10 (9)). Otherwise, it just leaves the state to 1139 -- True. 1140 1141 if S.Waiting then 1142 S.Waiting := False; 1143 S.State := False; 1144 1145 Result := semGive (S.CV); 1146 pragma Assert (Result = OK); 1147 else 1148 S.State := True; 1149 end if; 1150 1151 Result := semGive (S.L); 1152 pragma Assert (Result = OK); 1153 1154 -- Set_True can be called from an interrupt context, in which case 1155 -- Abort_Undefer is undefined. 1156 1157 if Is_Task_Context then 1158 SSL.Abort_Undefer.all; 1159 end if; 1160 1161 end Set_True; 1162 1163 ------------------------ 1164 -- Suspend_Until_True -- 1165 ------------------------ 1166 1167 procedure Suspend_Until_True (S : in out Suspension_Object) is 1168 Result : STATUS; 1169 1170 begin 1171 SSL.Abort_Defer.all; 1172 1173 Result := semTake (S.L, WAIT_FOREVER); 1174 1175 if S.Waiting then 1176 1177 -- Program_Error must be raised upon calling Suspend_Until_True 1178 -- if another task is already waiting on that suspension object 1179 -- (RM D.10(10)). 1180 1181 Result := semGive (S.L); 1182 pragma Assert (Result = OK); 1183 1184 SSL.Abort_Undefer.all; 1185 1186 raise Program_Error; 1187 1188 else 1189 -- Suspend the task if the state is False. Otherwise, the task 1190 -- continues its execution, and the state of the suspension object 1191 -- is set to False (RM D.10 (9)). 1192 1193 if S.State then 1194 S.State := False; 1195 1196 Result := semGive (S.L); 1197 pragma Assert (Result = 0); 1198 1199 SSL.Abort_Undefer.all; 1200 1201 else 1202 S.Waiting := True; 1203 1204 -- Release the mutex before sleeping 1205 1206 Result := semGive (S.L); 1207 pragma Assert (Result = OK); 1208 1209 SSL.Abort_Undefer.all; 1210 1211 Result := semTake (S.CV, WAIT_FOREVER); 1212 pragma Assert (Result = 0); 1213 end if; 1214 end if; 1215 end Suspend_Until_True; 1216 1217 ---------------- 1218 -- Check_Exit -- 1219 ---------------- 1220 1221 -- Dummy version 1222 1223 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is 1224 pragma Unreferenced (Self_ID); 1225 begin 1226 return True; 1227 end Check_Exit; 1228 1229 -------------------- 1230 -- Check_No_Locks -- 1231 -------------------- 1232 1233 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is 1234 pragma Unreferenced (Self_ID); 1235 begin 1236 return True; 1237 end Check_No_Locks; 1238 1239 ---------------------- 1240 -- Environment_Task -- 1241 ---------------------- 1242 1243 function Environment_Task return Task_Id is 1244 begin 1245 return Environment_Task_Id; 1246 end Environment_Task; 1247 1248 -------------- 1249 -- Lock_RTS -- 1250 -------------- 1251 1252 procedure Lock_RTS is 1253 begin 1254 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1255 end Lock_RTS; 1256 1257 ---------------- 1258 -- Unlock_RTS -- 1259 ---------------- 1260 1261 procedure Unlock_RTS is 1262 begin 1263 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1264 end Unlock_RTS; 1265 1266 ------------------ 1267 -- Suspend_Task -- 1268 ------------------ 1269 1270 function Suspend_Task 1271 (T : ST.Task_Id; 1272 Thread_Self : Thread_Id) return Boolean 1273 is 1274 begin 1275 if T.Common.LL.Thread /= Null_Thread_Id 1276 and then T.Common.LL.Thread /= Thread_Self 1277 then 1278 return taskSuspend (T.Common.LL.Thread) = 0; 1279 else 1280 return True; 1281 end if; 1282 end Suspend_Task; 1283 1284 ----------------- 1285 -- Resume_Task -- 1286 ----------------- 1287 1288 function Resume_Task 1289 (T : ST.Task_Id; 1290 Thread_Self : Thread_Id) return Boolean 1291 is 1292 begin 1293 if T.Common.LL.Thread /= Null_Thread_Id 1294 and then T.Common.LL.Thread /= Thread_Self 1295 then 1296 return taskResume (T.Common.LL.Thread) = 0; 1297 else 1298 return True; 1299 end if; 1300 end Resume_Task; 1301 1302 -------------------- 1303 -- Stop_All_Tasks -- 1304 -------------------- 1305 1306 procedure Stop_All_Tasks 1307 is 1308 Thread_Self : constant Thread_Id := taskIdSelf; 1309 C : Task_Id; 1310 1311 Dummy : int; 1312 Old : int; 1313 1314 begin 1315 Old := Int_Lock; 1316 1317 C := All_Tasks_List; 1318 while C /= null loop 1319 if C.Common.LL.Thread /= Null_Thread_Id 1320 and then C.Common.LL.Thread /= Thread_Self 1321 then 1322 Dummy := Task_Stop (C.Common.LL.Thread); 1323 end if; 1324 1325 C := C.Common.All_Tasks_Link; 1326 end loop; 1327 1328 Dummy := Int_Unlock (Old); 1329 end Stop_All_Tasks; 1330 1331 --------------- 1332 -- Stop_Task -- 1333 --------------- 1334 1335 function Stop_Task (T : ST.Task_Id) return Boolean is 1336 begin 1337 if T.Common.LL.Thread /= Null_Thread_Id then 1338 return Task_Stop (T.Common.LL.Thread) = 0; 1339 else 1340 return True; 1341 end if; 1342 end Stop_Task; 1343 1344 ------------------- 1345 -- Continue_Task -- 1346 ------------------- 1347 1348 function Continue_Task (T : ST.Task_Id) return Boolean 1349 is 1350 begin 1351 if T.Common.LL.Thread /= Null_Thread_Id then 1352 return Task_Cont (T.Common.LL.Thread) = 0; 1353 else 1354 return True; 1355 end if; 1356 end Continue_Task; 1357 1358 --------------------- 1359 -- Is_Task_Context -- 1360 --------------------- 1361 1362 function Is_Task_Context return Boolean is 1363 begin 1364 return System.OS_Interface.Interrupt_Context /= 1; 1365 end Is_Task_Context; 1366 1367 ---------------- 1368 -- Initialize -- 1369 ---------------- 1370 1371 procedure Initialize (Environment_Task : Task_Id) is 1372 Result : int; 1373 pragma Unreferenced (Result); 1374 1375 begin 1376 Environment_Task_Id := Environment_Task; 1377 1378 Interrupt_Management.Initialize; 1379 Specific.Initialize; 1380 1381 if Locking_Policy = 'C' then 1382 Mutex_Protocol := Prio_Protect; 1383 elsif Locking_Policy = 'I' then 1384 Mutex_Protocol := Prio_Inherit; 1385 else 1386 Mutex_Protocol := Prio_None; 1387 end if; 1388 1389 if Time_Slice_Val > 0 then 1390 Result := 1391 Set_Time_Slice 1392 (To_Clock_Ticks 1393 (Duration (Time_Slice_Val) / Duration (1_000_000.0))); 1394 1395 elsif Dispatching_Policy = 'R' then 1396 Result := Set_Time_Slice (To_Clock_Ticks (0.01)); 1397 1398 end if; 1399 1400 -- Initialize the lock used to synchronize chain of all ATCBs 1401 1402 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1403 1404 -- Make environment task known here because it doesn't go through 1405 -- Activate_Tasks, which does it for all other tasks. 1406 1407 Known_Tasks (Known_Tasks'First) := Environment_Task; 1408 Environment_Task.Known_Tasks_Index := Known_Tasks'First; 1409 1410 Enter_Task (Environment_Task); 1411 1412 -- Set processor affinity 1413 1414 Set_Task_Affinity (Environment_Task); 1415 end Initialize; 1416 1417 ----------------------- 1418 -- Set_Task_Affinity -- 1419 ----------------------- 1420 1421 procedure Set_Task_Affinity (T : ST.Task_Id) is 1422 Result : int := 0; 1423 pragma Unreferenced (Result); 1424 1425 use System.Task_Info; 1426 use type System.Multiprocessors.CPU_Range; 1427 1428 begin 1429 -- Do nothing if the underlying thread has not yet been created. If the 1430 -- thread has not yet been created then the proper affinity will be set 1431 -- during its creation. 1432 1433 if T.Common.LL.Thread = Null_Thread_Id then 1434 null; 1435 1436 -- pragma CPU 1437 1438 elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then 1439 1440 -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on 1441 -- VxWorks the first CPU is identified by a 0, so we need to adjust. 1442 1443 Result := 1444 taskCpuAffinitySet 1445 (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1); 1446 1447 -- Task_Info 1448 1449 elsif T.Common.Task_Info /= Unspecified_Task_Info then 1450 Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); 1451 1452 -- Handle dispatching domains 1453 1454 elsif T.Common.Domain /= null 1455 and then (T.Common.Domain /= ST.System_Domain 1456 or else T.Common.Domain.all /= 1457 (Multiprocessors.CPU'First .. 1458 Multiprocessors.Number_Of_CPUs => True)) 1459 then 1460 declare 1461 CPU_Set : unsigned := 0; 1462 1463 begin 1464 -- Set the affinity to all the processors belonging to the 1465 -- dispatching domain. 1466 1467 for Proc in T.Common.Domain'Range loop 1468 if T.Common.Domain (Proc) then 1469 1470 -- The thread affinity mask is a bit vector in which each 1471 -- bit represents a logical processor. 1472 1473 CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1); 1474 end if; 1475 end loop; 1476 1477 Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set); 1478 end; 1479 end if; 1480 end Set_Task_Affinity; 1481 1482end System.Task_Primitives.Operations; 1483