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