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-2011, 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 170 -- of 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 178 -- limit. Used 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 taskDelay (0); 593 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); 594 595 else 596 Result := semGive (Self_ID.Common.LL.L.Mutex); 597 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 674 -- so let's make another round after recomputing Ticks 675 -- from the absolute time. 676 677 if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then 678 Timedout := True; 679 else 680 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); 681 682 if Ticks < 0 then 683 Timedout := True; 684 end if; 685 end if; 686 end if; 687 688 -- Take back the lock after having slept, to protect further 689 -- access to Self_ID. 690 691 Result := 692 semTake 693 ((if Single_Lock 694 then Single_RTS_Lock.Mutex 695 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); 696 697 pragma Assert (Result = 0); 698 699 exit when Timedout; 700 end loop; 701 702 Self_ID.Common.State := Runnable; 703 704 Result := 705 semGive 706 (if Single_Lock 707 then Single_RTS_Lock.Mutex 708 else Self_ID.Common.LL.L.Mutex); 709 710 else 711 taskDelay (0); 712 end if; 713 end Timed_Delay; 714 715 --------------------- 716 -- Monotonic_Clock -- 717 --------------------- 718 719 function Monotonic_Clock return Duration is 720 TS : aliased timespec; 721 Result : int; 722 begin 723 Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); 724 pragma Assert (Result = 0); 725 return To_Duration (TS); 726 end Monotonic_Clock; 727 728 ------------------- 729 -- RT_Resolution -- 730 ------------------- 731 732 function RT_Resolution return Duration is 733 begin 734 return 1.0 / Duration (sysClkRateGet); 735 end RT_Resolution; 736 737 ------------ 738 -- Wakeup -- 739 ------------ 740 741 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is 742 pragma Unreferenced (Reason); 743 Result : int; 744 begin 745 Result := semGive (T.Common.LL.CV); 746 pragma Assert (Result = 0); 747 end Wakeup; 748 749 ----------- 750 -- Yield -- 751 ----------- 752 753 procedure Yield (Do_Yield : Boolean := True) is 754 pragma Unreferenced (Do_Yield); 755 Result : int; 756 pragma Unreferenced (Result); 757 begin 758 Result := taskDelay (0); 759 end Yield; 760 761 ------------------ 762 -- Set_Priority -- 763 ------------------ 764 765 procedure Set_Priority 766 (T : Task_Id; 767 Prio : System.Any_Priority; 768 Loss_Of_Inheritance : Boolean := False) 769 is 770 pragma Unreferenced (Loss_Of_Inheritance); 771 772 Result : int; 773 774 begin 775 Result := 776 taskPrioritySet 777 (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); 778 pragma Assert (Result = 0); 779 780 -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of 781 -- the priority queue instead of the head. This is not the behavior 782 -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable 783 -- variation (RM 1.1.3(6)), given this is the built-in behavior of the 784 -- operating system. VxWorks versions starting from 6.7 implement the 785 -- required Annex D semantics. 786 787 -- In older versions we attempted to better approximate the Annex D 788 -- required behavior, but this simulation was not entirely accurate, 789 -- and it seems better to live with the standard VxWorks semantics. 790 791 T.Common.Current_Priority := Prio; 792 end Set_Priority; 793 794 ------------------ 795 -- Get_Priority -- 796 ------------------ 797 798 function Get_Priority (T : Task_Id) return System.Any_Priority is 799 begin 800 return T.Common.Current_Priority; 801 end Get_Priority; 802 803 ---------------- 804 -- Enter_Task -- 805 ---------------- 806 807 procedure Enter_Task (Self_ID : Task_Id) is 808 begin 809 -- Store the user-level task id in the Thread field (to be used 810 -- internally by the run-time system) and the kernel-level task id in 811 -- the LWP field (to be used by the debugger). 812 813 Self_ID.Common.LL.Thread := taskIdSelf; 814 Self_ID.Common.LL.LWP := getpid; 815 816 Specific.Set (Self_ID); 817 818 -- Properly initializes the FPU for PPC/MIPS systems 819 820 System.Float_Control.Reset; 821 822 -- Install the signal handlers 823 824 -- This is called for each task since there is no signal inheritance 825 -- between VxWorks tasks. 826 827 Install_Signal_Handlers; 828 829 -- If stack checking is enabled, set the stack limit for this task 830 831 if Set_Stack_Limit_Hook /= null then 832 Set_Stack_Limit_Hook.all; 833 end if; 834 end Enter_Task; 835 836 ------------------- 837 -- Is_Valid_Task -- 838 ------------------- 839 840 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 841 842 ----------------------------- 843 -- Register_Foreign_Thread -- 844 ----------------------------- 845 846 function Register_Foreign_Thread return Task_Id is 847 begin 848 if Is_Valid_Task then 849 return Self; 850 else 851 return Register_Foreign_Thread (taskIdSelf); 852 end if; 853 end Register_Foreign_Thread; 854 855 -------------------- 856 -- Initialize_TCB -- 857 -------------------- 858 859 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is 860 begin 861 Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); 862 Self_ID.Common.LL.Thread := Null_Thread_Id; 863 864 if Self_ID.Common.LL.CV = 0 then 865 Succeeded := False; 866 867 else 868 Succeeded := True; 869 870 if not Single_Lock then 871 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); 872 end if; 873 end if; 874 end Initialize_TCB; 875 876 ----------------- 877 -- Create_Task -- 878 ----------------- 879 880 procedure Create_Task 881 (T : Task_Id; 882 Wrapper : System.Address; 883 Stack_Size : System.Parameters.Size_Type; 884 Priority : System.Any_Priority; 885 Succeeded : out Boolean) 886 is 887 Adjusted_Stack_Size : size_t; 888 889 use type System.Multiprocessors.CPU_Range; 890 891 begin 892 -- Check whether both Dispatching_Domain and CPU are specified for the 893 -- task, and the CPU value is not contained within the range of 894 -- processors for the domain. 895 896 if T.Common.Domain /= null 897 and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU 898 and then 899 (T.Common.Base_CPU not in T.Common.Domain'Range 900 or else not T.Common.Domain (T.Common.Base_CPU)) 901 then 902 Succeeded := False; 903 return; 904 end if; 905 906 -- Ask for four extra bytes of stack space so that the ATCB pointer can 907 -- be stored below the stack limit, plus extra space for the frame of 908 -- Task_Wrapper. This is so the user gets the amount of stack requested 909 -- exclusive of the needs. 910 911 -- We also have to allocate n more bytes for the task name storage and 912 -- enough space for the Wind Task Control Block which is around 0x778 913 -- bytes. VxWorks also seems to carve out additional space, so use 2048 914 -- as a nice round number. We might want to increment to the nearest 915 -- page size in case we ever support VxVMI. 916 917 -- ??? - we should come back and visit this so we can set the task name 918 -- to something appropriate. 919 920 Adjusted_Stack_Size := size_t (Stack_Size) + 2048; 921 922 -- Since the initial signal mask of a thread is inherited from the 923 -- creator, and the Environment task has all its signals masked, we do 924 -- not need to manipulate caller's signal mask at this point. All tasks 925 -- in RTS will have All_Tasks_Mask initially. 926 927 -- We now compute the VxWorks task name and options, then spawn ... 928 929 declare 930 Name : aliased String (1 .. T.Common.Task_Image_Len + 1); 931 Name_Address : System.Address; 932 -- Task name we are going to hand down to VxWorks 933 934 function Get_Task_Options return int; 935 pragma Import (C, Get_Task_Options, "__gnat_get_task_options"); 936 -- Function that returns the options to be set for the task that we 937 -- are creating. We fetch the options assigned to the current task, 938 -- so offering some user level control over the options for a task 939 -- hierarchy, and force VX_FP_TASK because it is almost always 940 -- required. 941 942 begin 943 -- If there is no Ada task name handy, let VxWorks choose one. 944 -- Otherwise, tell VxWorks what the Ada task name is. 945 946 if T.Common.Task_Image_Len = 0 then 947 Name_Address := System.Null_Address; 948 else 949 Name (1 .. Name'Last - 1) := 950 T.Common.Task_Image (1 .. T.Common.Task_Image_Len); 951 Name (Name'Last) := ASCII.NUL; 952 Name_Address := Name'Address; 953 end if; 954 955 -- Now spawn the VxWorks task for real 956 957 T.Common.LL.Thread := 958 taskSpawn 959 (Name_Address, 960 To_VxWorks_Priority (int (Priority)), 961 Get_Task_Options, 962 Adjusted_Stack_Size, 963 Wrapper, 964 To_Address (T)); 965 end; 966 967 -- Set processor affinity 968 969 Set_Task_Affinity (T); 970 971 if T.Common.LL.Thread <= Null_Thread_Id then 972 Succeeded := False; 973 else 974 Succeeded := True; 975 Task_Creation_Hook (T.Common.LL.Thread); 976 Set_Priority (T, Priority); 977 end if; 978 end Create_Task; 979 980 ------------------ 981 -- Finalize_TCB -- 982 ------------------ 983 984 procedure Finalize_TCB (T : Task_Id) is 985 Result : int; 986 987 begin 988 if not Single_Lock then 989 Result := semDelete (T.Common.LL.L.Mutex); 990 pragma Assert (Result = 0); 991 end if; 992 993 T.Common.LL.Thread := Null_Thread_Id; 994 995 Result := semDelete (T.Common.LL.CV); 996 pragma Assert (Result = 0); 997 998 if T.Known_Tasks_Index /= -1 then 999 Known_Tasks (T.Known_Tasks_Index) := null; 1000 end if; 1001 1002 ATCB_Allocation.Free_ATCB (T); 1003 end Finalize_TCB; 1004 1005 --------------- 1006 -- Exit_Task -- 1007 --------------- 1008 1009 procedure Exit_Task is 1010 begin 1011 Specific.Set (null); 1012 end Exit_Task; 1013 1014 ---------------- 1015 -- Abort_Task -- 1016 ---------------- 1017 1018 procedure Abort_Task (T : Task_Id) is 1019 Result : int; 1020 begin 1021 Result := 1022 kill 1023 (T.Common.LL.Thread, 1024 Signal (Interrupt_Management.Abort_Task_Interrupt)); 1025 pragma Assert (Result = 0); 1026 end Abort_Task; 1027 1028 ---------------- 1029 -- Initialize -- 1030 ---------------- 1031 1032 procedure Initialize (S : in out Suspension_Object) is 1033 begin 1034 -- Initialize internal state (always to False (RM D.10(6))) 1035 1036 S.State := False; 1037 S.Waiting := False; 1038 1039 -- Initialize internal mutex 1040 1041 -- Use simpler binary semaphore instead of VxWorks 1042 -- mutual exclusion semaphore, because we don't need 1043 -- the fancier semantics and their overhead. 1044 1045 S.L := semBCreate (SEM_Q_FIFO, SEM_FULL); 1046 1047 -- Initialize internal condition variable 1048 1049 S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY); 1050 end Initialize; 1051 1052 -------------- 1053 -- Finalize -- 1054 -------------- 1055 1056 procedure Finalize (S : in out Suspension_Object) is 1057 pragma Unmodified (S); 1058 -- S may be modified on other targets, but not on VxWorks 1059 1060 Result : STATUS; 1061 1062 begin 1063 -- Destroy internal mutex 1064 1065 Result := semDelete (S.L); 1066 pragma Assert (Result = OK); 1067 1068 -- Destroy internal condition variable 1069 1070 Result := semDelete (S.CV); 1071 pragma Assert (Result = OK); 1072 end Finalize; 1073 1074 ------------------- 1075 -- Current_State -- 1076 ------------------- 1077 1078 function Current_State (S : Suspension_Object) return Boolean is 1079 begin 1080 -- We do not want to use lock on this read operation. State is marked 1081 -- as Atomic so that we ensure that the value retrieved is correct. 1082 1083 return S.State; 1084 end Current_State; 1085 1086 --------------- 1087 -- Set_False -- 1088 --------------- 1089 1090 procedure Set_False (S : in out Suspension_Object) is 1091 Result : STATUS; 1092 1093 begin 1094 SSL.Abort_Defer.all; 1095 1096 Result := semTake (S.L, WAIT_FOREVER); 1097 pragma Assert (Result = OK); 1098 1099 S.State := False; 1100 1101 Result := semGive (S.L); 1102 pragma Assert (Result = OK); 1103 1104 SSL.Abort_Undefer.all; 1105 end Set_False; 1106 1107 -------------- 1108 -- Set_True -- 1109 -------------- 1110 1111 procedure Set_True (S : in out Suspension_Object) is 1112 Result : STATUS; 1113 1114 begin 1115 -- Set_True can be called from an interrupt context, in which case 1116 -- Abort_Defer is undefined. 1117 1118 if Is_Task_Context then 1119 SSL.Abort_Defer.all; 1120 end if; 1121 1122 Result := semTake (S.L, WAIT_FOREVER); 1123 pragma Assert (Result = OK); 1124 1125 -- If there is already a task waiting on this suspension object then 1126 -- we resume it, leaving the state of the suspension object to False, 1127 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves 1128 -- the state to True. 1129 1130 if S.Waiting then 1131 S.Waiting := False; 1132 S.State := False; 1133 1134 Result := semGive (S.CV); 1135 pragma Assert (Result = OK); 1136 else 1137 S.State := True; 1138 end if; 1139 1140 Result := semGive (S.L); 1141 pragma Assert (Result = OK); 1142 1143 -- Set_True can be called from an interrupt context, in which case 1144 -- Abort_Undefer is undefined. 1145 1146 if Is_Task_Context then 1147 SSL.Abort_Undefer.all; 1148 end if; 1149 1150 end Set_True; 1151 1152 ------------------------ 1153 -- Suspend_Until_True -- 1154 ------------------------ 1155 1156 procedure Suspend_Until_True (S : in out Suspension_Object) is 1157 Result : STATUS; 1158 1159 begin 1160 SSL.Abort_Defer.all; 1161 1162 Result := semTake (S.L, WAIT_FOREVER); 1163 1164 if S.Waiting then 1165 1166 -- Program_Error must be raised upon calling Suspend_Until_True 1167 -- if another task is already waiting on that suspension object 1168 -- (ARM D.10 par. 10). 1169 1170 Result := semGive (S.L); 1171 pragma Assert (Result = OK); 1172 1173 SSL.Abort_Undefer.all; 1174 1175 raise Program_Error; 1176 1177 else 1178 -- Suspend the task if the state is False. Otherwise, the task 1179 -- continues its execution, and the state of the suspension object 1180 -- is set to False (ARM D.10 par. 9). 1181 1182 if S.State then 1183 S.State := False; 1184 1185 Result := semGive (S.L); 1186 pragma Assert (Result = 0); 1187 1188 SSL.Abort_Undefer.all; 1189 1190 else 1191 S.Waiting := True; 1192 1193 -- Release the mutex before sleeping 1194 1195 Result := semGive (S.L); 1196 pragma Assert (Result = OK); 1197 1198 SSL.Abort_Undefer.all; 1199 1200 Result := semTake (S.CV, WAIT_FOREVER); 1201 pragma Assert (Result = 0); 1202 end if; 1203 end if; 1204 end Suspend_Until_True; 1205 1206 ---------------- 1207 -- Check_Exit -- 1208 ---------------- 1209 1210 -- Dummy version 1211 1212 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is 1213 pragma Unreferenced (Self_ID); 1214 begin 1215 return True; 1216 end Check_Exit; 1217 1218 -------------------- 1219 -- Check_No_Locks -- 1220 -------------------- 1221 1222 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is 1223 pragma Unreferenced (Self_ID); 1224 begin 1225 return True; 1226 end Check_No_Locks; 1227 1228 ---------------------- 1229 -- Environment_Task -- 1230 ---------------------- 1231 1232 function Environment_Task return Task_Id is 1233 begin 1234 return Environment_Task_Id; 1235 end Environment_Task; 1236 1237 -------------- 1238 -- Lock_RTS -- 1239 -------------- 1240 1241 procedure Lock_RTS is 1242 begin 1243 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1244 end Lock_RTS; 1245 1246 ---------------- 1247 -- Unlock_RTS -- 1248 ---------------- 1249 1250 procedure Unlock_RTS is 1251 begin 1252 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1253 end Unlock_RTS; 1254 1255 ------------------ 1256 -- Suspend_Task -- 1257 ------------------ 1258 1259 function Suspend_Task 1260 (T : ST.Task_Id; 1261 Thread_Self : Thread_Id) return Boolean 1262 is 1263 begin 1264 if T.Common.LL.Thread /= Null_Thread_Id 1265 and then T.Common.LL.Thread /= Thread_Self 1266 then 1267 return taskSuspend (T.Common.LL.Thread) = 0; 1268 else 1269 return True; 1270 end if; 1271 end Suspend_Task; 1272 1273 ----------------- 1274 -- Resume_Task -- 1275 ----------------- 1276 1277 function Resume_Task 1278 (T : ST.Task_Id; 1279 Thread_Self : Thread_Id) return Boolean 1280 is 1281 begin 1282 if T.Common.LL.Thread /= Null_Thread_Id 1283 and then T.Common.LL.Thread /= Thread_Self 1284 then 1285 return taskResume (T.Common.LL.Thread) = 0; 1286 else 1287 return True; 1288 end if; 1289 end Resume_Task; 1290 1291 -------------------- 1292 -- Stop_All_Tasks -- 1293 -------------------- 1294 1295 procedure Stop_All_Tasks 1296 is 1297 Thread_Self : constant Thread_Id := taskIdSelf; 1298 C : Task_Id; 1299 1300 Dummy : int; 1301 pragma Unreferenced (Dummy); 1302 1303 begin 1304 Dummy := Int_Lock; 1305 1306 C := All_Tasks_List; 1307 while C /= null loop 1308 if C.Common.LL.Thread /= Null_Thread_Id 1309 and then C.Common.LL.Thread /= Thread_Self 1310 then 1311 Dummy := Task_Stop (C.Common.LL.Thread); 1312 end if; 1313 1314 C := C.Common.All_Tasks_Link; 1315 end loop; 1316 1317 Dummy := Int_Unlock; 1318 end Stop_All_Tasks; 1319 1320 --------------- 1321 -- Stop_Task -- 1322 --------------- 1323 1324 function Stop_Task (T : ST.Task_Id) return Boolean is 1325 begin 1326 if T.Common.LL.Thread /= Null_Thread_Id then 1327 return Task_Stop (T.Common.LL.Thread) = 0; 1328 else 1329 return True; 1330 end if; 1331 end Stop_Task; 1332 1333 ------------------- 1334 -- Continue_Task -- 1335 ------------------- 1336 1337 function Continue_Task (T : ST.Task_Id) return Boolean 1338 is 1339 begin 1340 if T.Common.LL.Thread /= Null_Thread_Id then 1341 return Task_Cont (T.Common.LL.Thread) = 0; 1342 else 1343 return True; 1344 end if; 1345 end Continue_Task; 1346 1347 --------------------- 1348 -- Is_Task_Context -- 1349 --------------------- 1350 1351 function Is_Task_Context return Boolean is 1352 begin 1353 return System.OS_Interface.Interrupt_Context /= 1; 1354 end Is_Task_Context; 1355 1356 ---------------- 1357 -- Initialize -- 1358 ---------------- 1359 1360 procedure Initialize (Environment_Task : Task_Id) is 1361 Result : int; 1362 pragma Unreferenced (Result); 1363 1364 begin 1365 Environment_Task_Id := Environment_Task; 1366 1367 Interrupt_Management.Initialize; 1368 Specific.Initialize; 1369 1370 if Locking_Policy = 'C' then 1371 Mutex_Protocol := Prio_Protect; 1372 elsif Locking_Policy = 'I' then 1373 Mutex_Protocol := Prio_Inherit; 1374 else 1375 Mutex_Protocol := Prio_None; 1376 end if; 1377 1378 if Time_Slice_Val > 0 then 1379 Result := 1380 Set_Time_Slice 1381 (To_Clock_Ticks 1382 (Duration (Time_Slice_Val) / Duration (1_000_000.0))); 1383 1384 elsif Dispatching_Policy = 'R' then 1385 Result := Set_Time_Slice (To_Clock_Ticks (0.01)); 1386 1387 end if; 1388 1389 -- Initialize the lock used to synchronize chain of all ATCBs 1390 1391 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1392 1393 -- Make environment task known here because it doesn't go through 1394 -- Activate_Tasks, which does it for all other tasks. 1395 1396 Known_Tasks (Known_Tasks'First) := Environment_Task; 1397 Environment_Task.Known_Tasks_Index := Known_Tasks'First; 1398 1399 Enter_Task (Environment_Task); 1400 1401 -- Set processor affinity 1402 1403 Set_Task_Affinity (Environment_Task); 1404 end Initialize; 1405 1406 ----------------------- 1407 -- Set_Task_Affinity -- 1408 ----------------------- 1409 1410 procedure Set_Task_Affinity (T : ST.Task_Id) is 1411 Result : int := 0; 1412 pragma Unreferenced (Result); 1413 1414 use System.Task_Info; 1415 use type System.Multiprocessors.CPU_Range; 1416 1417 begin 1418 -- Do nothing if the underlying thread has not yet been created. If the 1419 -- thread has not yet been created then the proper affinity will be set 1420 -- during its creation. 1421 1422 if T.Common.LL.Thread = Null_Thread_Id then 1423 null; 1424 1425 -- pragma CPU 1426 1427 elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then 1428 1429 -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on 1430 -- VxWorks the first CPU is identified by a 0, so we need to adjust. 1431 1432 Result := 1433 taskCpuAffinitySet 1434 (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1); 1435 1436 -- Task_Info 1437 1438 elsif T.Common.Task_Info /= Unspecified_Task_Info then 1439 Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); 1440 1441 -- Handle dispatching domains 1442 1443 elsif T.Common.Domain /= null 1444 and then (T.Common.Domain /= ST.System_Domain 1445 or else T.Common.Domain.all /= 1446 (Multiprocessors.CPU'First .. 1447 Multiprocessors.Number_Of_CPUs => True)) 1448 then 1449 declare 1450 CPU_Set : unsigned := 0; 1451 1452 begin 1453 -- Set the affinity to all the processors belonging to the 1454 -- dispatching domain. 1455 1456 for Proc in T.Common.Domain'Range loop 1457 if T.Common.Domain (Proc) then 1458 1459 -- The thread affinity mask is a bit vector in which each 1460 -- bit represents a logical processor. 1461 1462 CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1); 1463 end if; 1464 end loop; 1465 1466 Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set); 1467 end; 1468 end if; 1469 end Set_Task_Affinity; 1470 1471end System.Task_Primitives.Operations; 1472