gcc/ada/libgnarl/s-taprop__vxworks.adb

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