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