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