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