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