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