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